1 subroutine trauthin(nthinerr)
2 !--------------------------------------------------------------------------
3 !
4 ! TRACK THIN LENS PART
5 !
6 !
7 ! F. SCHMIDT
8 !
9 !
10 ! CHANGES FOR COLLIMATION MADE BY G. ROBERT-DEMOLAIZE, October 29th, 2004
11 !--------------------------------------------------------------------------
12 implicit none
13 integer i,ix,j,jb,jj,jx,kpz,kzz,napx0,nbeaux,nmz,nthinerr
14 double precision benkcc,cbxb,cbzb,cikveb,crkveb,crxb,crzb,r0,r000,&
15 &r0a,r2b,rb,rho2b,rkb,tkb,xbb,xrb,zbb,zrb
16 integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1, &
17 &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran, &
18 &nrco,ntr,nzfz
19 parameter(npart = 64,nmac = 1)
20 parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000, &
21 &nzfz = 300000,mmul = 11)
22 parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5, &
23 &nema = 15)
24 parameter(mcor = 10,mcop = mcor+6, mbea = 15)
25 parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
26 parameter(nmon1 = 600,ncor1 = 600)
27 parameter(ntr = 20,nbb = 160)
28 double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3, &
29 &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21, &
30 &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
31 &one,pieni,pmae,pmap,three,two,zero
32 parameter(pieni = 1d-38)
33 parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
34 parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
35 parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
36 parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
37 parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 = &
38 &1.0d16)
39 parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
40 parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
41 parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
42 parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
43 parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
44 parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
45 parameter(pmap = 938.271998d0,pmae = .510998902d0)
46 parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
47 integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo, &
48 &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor, &
49 &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb, &
50 &imc,imtr,iorg,iout, &
51 &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires, &
52 &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw, &
53 &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox, &
54 &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo, &
55 &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx, &
56 &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr, &
57 &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew, &
58 &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr, &
59 &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
60 double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu, &
61 &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
62 &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft, &
63 &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
64 &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign, &
65 &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum, &
66 &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
67 &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph, &
68 &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
69 &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel, &
70 &acdipph
71 real hmal
72 character*16 bez,bezb,bezr,erbez,bezl
73 character*80 toptit,sixtit,commen
74 common/erro/ierro,erbez
75 common/kons/pi,pi2,pisqrt,rad
76 common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
77 common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
78 common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
79 common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
80 common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
81 common/syos2/rvf(mpa)
82 common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
83 &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
84 common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3), &
85 &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen, &
86 &iicav,itionc(nele),ition,idp,ncy,ixcav
87 common/corcom/dpscor,sigcor,icode,idam,its6d
88 common/multi/bk0(nele,mmul),ak0(nele,mmul), &
89 &bka(nele,mmul),aka(nele,mmul)
90 common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
91 common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
92 common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz), &
93 &tilts(nblz),mout2,icext(nblz),icextal(nblz)
94 common/beo /aper(2),di0(2),dip0(2),ta(6,6)
95 common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
96 &iout
97 common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
98 common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint, &
99 &ntco,eui,euii,nlin,bezl(nele)
100 common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2), &
101 &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr, &
102 &ncororb(nele)
103 common/apert/apx(nele),apz(nele),ape(3,nele)
104 common/clos/sigma0(2),iclo,ncorru,ncorrep
105 common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20), &
106 &ratioe(nele),iratioe(nele),icoe
107 common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
108 common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
109 common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
110 common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
111 common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2, &
112 &nstart,nstop,iskip,iconv,imad
113 common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
114 common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
115 common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
116 common/ripp2/nrturn
117 common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
118 common/pawc/hmal(nplo)
119 common/tit/sixtit,commen,ithick
120 common/co6d/clo6(3),clop6(3)
121 common/dkic/dki(nele,3)
122 common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb), &
123 &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart), &
124 &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar, &
125 &nbeam,ibbc,ibeco,ibtyp,lhc
126 common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
127 common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
128 common/wireco/ wirel(nele)
129 common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele), &
130 &nturn3(nele), nturn4(nele)
131 integer idz,itra
132 double precision al,as,chi0,chid,dp1,dps,exz,sigm
133 common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa), &
134 &dps(mpa),idz(2)
135 common/anf/chi0,chid,exz(2,6),dp1,itra
136 integer ichrom,is
137 double precision alf0,amp,bet0,clo,clop,cro,x,y
138 common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
139 common/chrom/cro(2),is(2),ichrom
140 integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
141 &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
142 double precision dpmax,preda,weig1,weig2
143 character*16 coel
144 common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
145 common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
146 common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
147 &coel(10)
148 double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
149 &zsi
150 real tlim,time0,time1
151 common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz), &
152 &aai(nblz,mmul),bbi(nblz,mmul)
153 common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
154 common/damp/damp,ampt
155 common/ttime/tlim,time0,time1
156 double precision tasm
157 common/tasm/tasm(6,6)
158 integer iv,ixv,nlostp,nms,numxv
159 double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
160 &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
161 &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl, &
162 &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
163 &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv, &
164 &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas, &
165 &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
166 &zsiv,zsv
167 logical pstop
168 common/main1/ &
169 &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz), &
170 &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz), &
171 &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2), &
172 &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart), &
173 &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart), &
174 &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart), &
175 &xlv(npart),zlv(npart),pstop(npart),rvv(npart), &
176 &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
177 common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart), &
178 &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart), &
179 &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart), &
180 &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart), &
181 &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart), &
182 &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
183 &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
184 &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart), &
185 &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
186 common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo), &
187 &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart), &
188 &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6), &
189 &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
190 integer numx
191 double precision e0f
192 common/main4/ e0f,numx
193 integer ktrack,nwri
194 double precision dpsv1,strack,strackc,stracks
195 common/track/ ktrack(nblz),strack(nblz),strackc(nblz), &
196 &stracks(nblz),dpsv1(npart),nwri
197 double precision cc,xlim,ylim
198 parameter(cc = 1.12837916709551d0)
199 parameter(xlim = 5.33d0)
200 parameter(ylim = 4.29d0)
201 dimension crkveb(npart),cikveb(npart),rho2b(npart),tkb(npart), &
202 &r2b(npart),rb(npart),rkb(npart), &
203 &xrb(npart),zrb(npart),xbb(npart),zbb(npart),crxb(npart), &
204 &crzb(npart),cbxb(npart),cbzb(npart)
205 dimension nbeaux(nbb)
206 integer max_ncoll,max_npart,maxn,numeff,outlun,nc
207 parameter (max_ncoll=100,max_npart=20000,nc=32,numeff=19, &
208 &maxn=20000,outlun=54)
209 integer mynp
210 common /mynp/ mynp
211 !
212 logical cut_input
213 common /cut/ cut_input
214 !
215 !++ Vectors of coordinates
216 double precision myemitx,mygammax,myemity,mygammay,xsigmax,ysigmay
217 !
218 real rndm4
219 !
220 character*80 dummy
221 !
222 double precision remitxn,remityn,remitx,remity
223 common /remit/ remitxn, remityn, remitx, remity
224 !
225 double precision mux(nblz),muy(nblz)
226 common /mu/ mux,muy
227 !
228 double precision ielem,iclr,grd
229 character*80 ch
230 character*160 ch1
231 logical flag
232 !
233 integer k,np0,rnd_lux,rnd_k1,rnd_k2
234 !
235 double precision ax0,ay0,bx0,by0,mux0,muy0,nspx,nspy
236 !
237 double precision xbob(nblz),ybob(nblz),xpbob(nblz),ypbob(nblz), &
238 &xineff(npart),yineff(npart),xpineff(npart),ypineff(npart)
239 !
240 common /xcheck/ xbob,ybob,xpbob,ypbob,xineff,yineff,xpineff, &
241 &ypineff
242 !
243 integer mclock_liar
244 !
245 character*160 cmd
246 character*160 cmd2
247 character*1 ch0
248 character*2 ch00
249 character*3 ch000
250 character*4 ch0000
251 !
252 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
253 !
254 !GRD
255 !GRD THIS BLOC IS COMMON TO MAINCR, DATEN, TRAUTHIN AND THIN6D
256 !GRD
257 !APRIL2005
258 logical do_coll,do_select,do_nominal,dowrite_dist,do_oneside, &
259 &dowrite_impact,dowrite_secondary,dowrite_amplitude,radial, &
260 &systilt_antisymm,dowritetracks,cern,do_nsig,do_mingap
261 !
262 integer nloop,rnd_seed,c_offsettilt_seed,ibeam,jobnumber, &
263 &do_thisdis,n_slices,pencil_distr
264 double precision myenom,mynex,mdex,myney,mdey, &
265 &nsig_tcp3,nsig_tcsg3,nsig_tcsm3,nsig_tcla3, &
266 &nsig_tcp7,nsig_tcsg7,nsig_tcsm7,nsig_tcla7,nsig_tclp,nsig_tcli, &
267 !
268 &nsig_tcth1,nsig_tcth2,nsig_tcth5,nsig_tcth8, &
269 &nsig_tctv1,nsig_tctv2,nsig_tctv5,nsig_tctv8, &
270 !
271 &nsig_tcdq,nsig_tcstcdq,nsig_tdi,nsig_tcxrp,nsig_tcryo, nsig_cry, &
272 !SEPT2005 add these lines for the slicing procedure
273 &smin_slices,smax_slices,recenter1,recenter2, &
274 &fit1_1,fit1_2,fit1_3,fit1_4,fit1_5,fit1_6,ssf1, &
275 &fit2_1,fit2_2,fit2_3,fit2_4,fit2_5,fit2_6,ssf2, &
276 !SEPT2005,OCT2006 added offset
277 &emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase, &
278 &c_rmstilt_prim,c_rmstilt_sec,c_systilt_prim,c_systilt_sec, &
279 &c_rmsoffset_prim,c_rmsoffset_sec,c_sysoffset_prim, &
280 &c_sysoffset_sec,c_rmserror_gap,nr,ndr, &
281 ! &driftsx,driftsy,pencil_offset,sigsecut3
282 !JUNE2005
283 &driftsx,driftsy,pencil_offset,pencil_rmsx,pencil_rmsy, &
284 &sigsecut3,sigsecut2,enerror,bunchlength
285 !
286 character*24 name_sel
287 character*80 coll_db
288 character*16 castordir
289 !JUNE2005
290 character*80 filename_dis
291 !JUNE2005
292 common /grd/ myenom,mynex,mdex,myney,mdey, &
293 &nsig_tcp3,nsig_tcsg3,nsig_tcsm3,nsig_tcla3, &
294 &nsig_tcp7,nsig_tcsg7,nsig_tcsm7,nsig_tcla7,nsig_tclp,nsig_tcli, &
295 !
296 &nsig_tcth1,nsig_tcth2,nsig_tcth5,nsig_tcth8, &
297 &nsig_tctv1,nsig_tctv2,nsig_tctv5,nsig_tctv8, &
298 !
299 &nsig_tcdq,nsig_tcstcdq,nsig_tdi,nsig_tcxrp,nsig_tcryo, nsig_cry, &
300 !
301 &smin_slices,smax_slices,recenter1,recenter2, &
302 &fit1_1,fit1_2,fit1_3,fit1_4,fit1_5,fit1_6,ssf1, &
303 &fit2_1,fit2_2,fit2_3,fit2_4,fit2_5,fit2_6,ssf2, &
304 !
305 &emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase, &
306 &c_rmstilt_prim,c_rmstilt_sec,c_systilt_prim,c_systilt_sec, &
307 &c_rmsoffset_prim,c_rmsoffset_sec,c_sysoffset_prim, &
308 &c_sysoffset_sec,c_rmserror_gap,nr, &
309 !
310 &ndr,driftsx,driftsy,pencil_offset,pencil_rmsx,pencil_rmsy, &
311 &sigsecut3,sigsecut2,enerror, &
312 &bunchlength,coll_db,name_sel, &
313 &castordir,filename_dis,nloop,rnd_seed,c_offsettilt_seed, &
314 &ibeam,jobnumber,do_thisdis,n_slices,pencil_distr, &
315 &do_coll, &
316 !
317 &do_select,do_nominal,dowrite_dist,do_oneside,dowrite_impact, &
318 &dowrite_secondary,dowrite_amplitude,radial,systilt_antisymm, &
319 &dowritetracks,cern,do_nsig,do_mingap
320 !
321 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
322 !
323 !
324 ! THIS BLOCK IS COMMON TO BOTH THIN6D AND TRAUTHIN SUBROUTINES
325 !
326 integer ieff
327 !
328 double precision myemitx0,myemity0,myalphay,mybetay,myalphax, &
329 &mybetax,rselect
330 common /ralph/ myemitx0,myemity0,myalphax,myalphay,mybetax, &
331 &mybetay,rselect
332 !
333 integer absorbed(npart),counted(npart,numeff)
334 double precision neff(numeff),rsig(numeff)
335 common /eff/ neff,rsig,counted,absorbed
336 !
337 integer nimpact(50)
338 double precision sumimpact(50),sqsumimpact(50)
339 common /rimpact/ sumimpact,sqsumimpact,nimpact
340 !
341 integer nampl(nblz)
342 character*16 ename(nblz)
343 double precision sum_ax(nblz),sqsum_ax(nblz),sum_ay(nblz), &
344 &sqsum_ay(nblz),sampl(nblz)
345 common /ampl_rev/ sum_ax,sqsum_ax,sum_ay,sqsum_ay,sampl,ename, &
346 &nampl
347 !
348 double precision neffx(numeff),neffy(numeff)
349 common /efficiency/ neffx,neffy
350 !
351 integer part_hit(maxn),part_abs(maxn),n_tot_absorbed,n_absorbed &
352 &,part_select(maxn)
353 double precision part_impact(maxn)
354 common /stats/ part_impact,part_hit,part_abs
355 common /n_tot_absorbed/ n_tot_absorbed,n_absorbed
356 common /part_select/ part_select
357 !
358 double precision x00(maxn),xp00(maxn),y00(maxn),yp00(maxn)
359 common /beam00/ x00,xp00,y00,yp00
360 !
361 logical firstrun
362 common /firstrun/ firstrun
363 !
364 integer nsurvive,nsurvive_end,num_selhit,n_impact
365 common /outcoll/ nsurvive,num_selhit,n_impact,nsurvive_end
366 !
367 integer napx00
368 common /napx00/ napx00
369 !
370 integer icoll
371 common /icoll/ icoll
372
373
374 !
375 integer db_ncoll
376 !
377 character*16 db_name1(max_ncoll),db_name2(max_ncoll)
378 character*6 db_material(max_ncoll)
379 double precision db_nsig(max_ncoll),db_length(max_ncoll), &
380 &db_offset(max_ncoll),db_rotation(max_ncoll), &
381 &db_bx(max_ncoll),db_by(max_ncoll),db_tilt(max_ncoll,2), &
382 &db_elense_thickness(max_ncoll),db_elense_j_e(max_ncoll)
383 &,db_cry_rcurv(max_ncoll),db_cry_rmax(max_ncoll), &
384 &db_cry_zmax(max_ncoll),db_cry_alayer(max_ncoll), &
385 &db_cry_orient(max_ncoll),db_cry_tilt(max_ncoll)
386 &,db_miscut(max_ncoll)
387 common /colldatabase/ db_nsig,db_length,db_rotation,db_offset, &
388 &db_bx,db_by,db_tilt,db_name1,db_name2,db_material,db_ncoll, &
389 &db_elense_thickness,db_elense_j_e
390 &,db_cry_rcurv,db_cry_rmax,db_cry_zmax,db_cry_alayer,db_cry_orient,&
391 &db_cry_tilt,db_miscut
392 !
393 integer cn_impact(max_ncoll),cn_absorbed(max_ncoll)
394 double precision caverage(max_ncoll),csigma(max_ncoll)
395 common /collsummary/ caverage,csigma,cn_impact,cn_absorbed
396 !
397 double precision myx(maxn),myxp(maxn),myy(maxn),myyp(maxn), &
398 &myp(maxn),mys(maxn)
399 common /coord/ myx,myxp,myy,myyp,myp,mys
400 !
401 integer counted_r(maxn,numeff),counted_x(maxn,numeff), &
402 &counted_y(maxn,numeff), &
403 &ieffmax_r(npart),ieffmax_x(npart),ieffmax_y(npart)
404 common /counting/ counted_r,counted_x,counted_y,ieffmax_r, &
405 &ieffmax_x, ieffmax_y
406 !
407 integer secondary(maxn),tertiary(maxn),other(maxn), &
408 &part_hit_before(maxn)
409 double precision part_indiv(maxn),part_linteract(maxn)
410 !
411 integer samplenumber
412 character*4 smpl
413 character*80 pfile
414 common /samplenumber/ pfile,smpl,samplenumber
415 !
416 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
417 !
418 !
419 ! THIS BLOCK IS COMMON TO WRITELIN,LINOPT,TRAUTHIN,THIN6D AND MAINCR
420 !
421 double precision tbetax(nblz),tbetay(nblz),talphax(nblz), &
422 &talphay(nblz),torbx(nblz),torbxp(nblz),torby(nblz),torbyp(nblz), &
423 &tdispx(nblz),tdispy(nblz)
424 !
425 common /rtwiss/ tbetax,tbetay,talphax,talphay,torbx,torbxp, &
426 &torby,torbyp,tdispx,tdispy
427 !
428 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
429 !
430 !
431 ! THIS BLOCK IS COMMON TO THIN6D, TRAUTHIN, COLLIMATE32 AND MAINCR
432 !
433 integer ipencil
434 double precision xp_pencil0,yp_pencil0,x_pencil(max_ncoll), &
435 &y_pencil(max_ncoll),pencil_dx(max_ncoll)
436 common /pencil/ xp_pencil0,yp_pencil0,pencil_dx,ipencil
437 common /pencil2/ x_pencil, y_pencil
438 !
439 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
440 !
441 integer ie,iturn,nabs_total
442 common /info/ ie,iturn,nabs_total
443 !
444 !
445 ! SEPT2008: valentina add flags for cry output
446 !
447 logical write_c_out, write_SPS_out
448 common /outputs/ write_c_out, write_SPS_out
449
450
451 double precision xdebug(nblz),xdebugN(nblz),xpdebug(nblz),
452 & xpdebugN(nblz),
453 & ydebug(nblz),ydebugN(nblz),ypdebug(nblz),ypdebugN(nblz)
454 common /debugvale/xdebug,xdebugN,xpdebug,xpdebugN,
455 &ydebug,ydebugN,ypdebug,ypdebugN
456
457 save
458 !-----------------------------------------------------------------------
459 write_c_out= .true. !valentina
460 c
461 c
462 c
463 do 5 i=1,npart
464 nlostp(i)=i
465 5 continue
466 do 10 i=1,nblz
467 ktrack(i)=0
468 strack(i)=zero
469 strackc(i)=zero
470 stracks(i)=zero
471 10 continue
472 !--beam-beam element
473 if(nbeam.ge.1) then
474 do 15 i=1,nbb
475 nbeaux(i)=0
476 15 continue
477 do i=1,iu
478 ix=ic(i)
479 if(ix.gt.nblo) then
480 ix=ix-nblo
481 if(kz(ix).eq.20.and.parbe(ix,2).eq.0) then
482 !--round beam
483 if(sigman(1,imbb(i)).eq.sigman(2,imbb(i))) then
484 if(nbeaux(imbb(i)).eq.2.or.nbeaux(imbb(i)).eq.3) then
485 call prror(89)
486 else
487 nbeaux(imbb(i))=1
488 sigman2(1,imbb(i))=sigman(1,imbb(i))**2
489 endif
490 endif
491 !--elliptic beam x>z
492 if(sigman(1,imbb(i)).gt.sigman(2,imbb(i))) then
493 if(nbeaux(imbb(i)).eq.1.or.nbeaux(imbb(i)).eq.3) then
494 call prror(89)
495 else
496 nbeaux(imbb(i))=2
497 sigman2(1,imbb(i))=sigman(1,imbb(i))**2
498 sigman2(2,imbb(i))=sigman(2,imbb(i))**2
499 sigmanq(1,imbb(i))=sigman(1,imbb(i))/sigman(2,imbb(i))
500 sigmanq(2,imbb(i))=sigman(2,imbb(i))/sigman(1,imbb(i))
501 endif
502 endif
503 !--elliptic beam z>x
504 if(sigman(1,imbb(i)).lt.sigman(2,imbb(i))) then
505 if(nbeaux(imbb(i)).eq.1.or.nbeaux(imbb(i)).eq.2) then
506 call prror(89)
507 else
508 nbeaux(imbb(i))=3
509 sigman2(1,imbb(i))=sigman(1,imbb(i))**2
510 sigman2(2,imbb(i))=sigman(2,imbb(i))**2
511 sigmanq(1,imbb(i))=sigman(1,imbb(i))/sigman(2,imbb(i))
512 sigmanq(2,imbb(i))=sigman(2,imbb(i))/sigman(1,imbb(i))
513 endif
514 endif
515 endif
516 endif
517 enddo
518 endif
519
520 do 290 i=1,iu
521 if(mout2.eq.1.and.i.eq.1) call write4
522 ix=ic(i)
523 if(ix.gt.nblo) goto 30
524 ktrack(i)=1
525 do 20 jb=1,mel(ix)
526 jx=mtyp(ix,jb)
527 strack(i)=strack(i)+el(jx)
528 20 continue
529 if(abs(strack(i)).le.pieni) ktrack(i)=31
530 goto 290
531 30 ix=ix-nblo
532 kpz=abs(kp(ix))
533 if(kpz.eq.6) then
534 ktrack(i)=2
535 goto 290
536 endif
537 40 kzz=kz(ix)
538 if(kzz.eq.0) then
539 ktrack(i)=31
540 goto 290
541 endif
542 !--beam-beam element
543 if(kzz.eq.20.and.nbeam.ge.1.and.parbe(ix,2).eq.0) then
544 strack(i)=crad*ptnfac(ix)
545 if(abs(strack(i)).le.pieni) then
546 ktrack(i)=31
547 goto 290
548 endif
549 if(nbeaux(imbb(i)).eq.1) then
550 ktrack(i)=41
551 if(ibeco.eq.1) then
552 do 42 j=1,napx
553 if(ibbc.eq.0) then
554 crkveb(j)=ed(ix)
555 cikveb(j)=ek(ix)
556 else
557 crkveb(j)=ed(ix)*bbcu(imbb(i),11)+ &
558 &ek(ix)*bbcu(imbb(i),12)
559 cikveb(j)=-ed(ix)*bbcu(imbb(i),12)+ &
560 &ek(ix)*bbcu(imbb(i),11)
561 endif
562 rho2b(j)=crkveb(j)*crkveb(j)+cikveb(j)*cikveb(j)
563 if(rho2b(j).le.pieni) &
564 &goto 42
565 tkb(j)=rho2b(j)/(two*sigman2(1,imbb(i)))
566 beamoff(4,imbb(i))=strack(i)*crkveb(j)/rho2b(j)* &
567 &(one-exp(-tkb(j)))
568 beamoff(5,imbb(i))=strack(i)*cikveb(j)/rho2b(j)* &
569 &(one-exp(-tkb(j)))
570 42 continue
571 endif
572 endif
573 if(nbeaux(imbb(i)).eq.2) then
574 ktrack(i)=42
575 if(ibeco.eq.1) then
576 if(ibtyp.eq.0) then
577 do j=1,napx
578 r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
579 rb(j)=sqrt(r2b(j))
580 rkb(j)=strack(i)*pisqrt/rb(j)
581 if(ibbc.eq.0) then
582 crkveb(j)=ed(ix)
583 cikveb(j)=ek(ix)
584 else
585 crkveb(j)=ed(ix)*bbcu(imbb(i),11)+ &
586 &ek(ix)*bbcu(imbb(i),12)
587 cikveb(j)=-ed(ix)*bbcu(imbb(i),12)+ &
588 &ek(ix)*bbcu(imbb(i),11)
589 endif
590 xrb(j)=abs(crkveb(j))/rb(j)
591 zrb(j)=abs(cikveb(j))/rb(j)
592 call errf(xrb(j),zrb(j),crxb(j),crzb(j))
593 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
594 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
595 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
596 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
597 call errf(xbb(j),zbb(j),cbxb(j),cbzb(j))
598 beamoff(4,imbb(i))=rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
599 &sign(one,crkveb(j))
600 beamoff(5,imbb(i))=rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
601 &sign(one,cikveb(j))
602 enddo
603 else if(ibtyp.eq.1) then
604 do j=1,napx
605 r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
606 rb(j)=sqrt(r2b(j))
607 rkb(j)=strack(i)*pisqrt/rb(j)
608 if(ibbc.eq.0) then
609 crkveb(j)=ed(ix)
610 cikveb(j)=ek(ix)
611 else
612 crkveb(j)=ed(ix)*bbcu(imbb(i),11)+ &
613 &ek(ix)*bbcu(imbb(i),12)
614 cikveb(j)=-ed(ix)*bbcu(imbb(i),12)+ &
615 &ek(ix)*bbcu(imbb(i),11)
616 endif
617 xrb(j)=abs(crkveb(j))/rb(j)
618 zrb(j)=abs(cikveb(j))/rb(j)
619 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
620 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
621 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
622 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
623 enddo
624 call wzsubv(napx,xrb(1),zrb(1),crxb(1),crzb(1))
625 call wzsubv(napx,xbb(1),zbb(1),cbxb(1),cbzb(1))
626 do j=1,napx
627 beamoff(4,imbb(i))=rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
628 &sign(one,crkveb(j))
629 beamoff(5,imbb(i))=rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
630 &sign(one,cikveb(j))
631 enddo
632 endif
633 endif
634 endif
635 if(nbeaux(imbb(i)).eq.3) then
636 ktrack(i)=43
637 if(ibeco.eq.1) then
638 if(ibtyp.eq.0) then
639 do j=1,napx
640 r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
641 rb(j)=sqrt(r2b(j))
642 rkb(j)=strack(i)*pisqrt/rb(j)
643 if(ibbc.eq.0) then
644 crkveb(j)=ed(ix)
645 cikveb(j)=ek(ix)
646 else
647 crkveb(j)=ed(ix)*bbcu(imbb(i),11)+ &
648 &ek(ix)*bbcu(imbb(i),12)
649 cikveb(j)=-ed(ix)*bbcu(imbb(i),12)+ &
650 &ek(ix)*bbcu(imbb(i),11)
651 endif
652 xrb(j)=abs(crkveb(j))/rb(j)
653 zrb(j)=abs(cikveb(j))/rb(j)
654 call errf(zrb(j),xrb(j),crzb(j),crxb(j))
655 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
656 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
657 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
658 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
659 call errf(zbb(j),xbb(j),cbzb(j),cbxb(j))
660 beamoff(4,imbb(i))=rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
661 &sign(one,crkveb(j))
662 beamoff(5,imbb(i))=rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
663 &sign(one,cikveb(j))
664 enddo
665 else if(ibtyp.eq.1) then
666 do j=1,napx
667 r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
668 rb(j)=sqrt(r2b(j))
669 rkb(j)=strack(i)*pisqrt/rb(j)
670 if(ibbc.eq.0) then
671 crkveb(j)=ed(ix)
672 cikveb(j)=ek(ix)
673 else
674 crkveb(j)=ed(ix)*bbcu(imbb(i),11)+ &
675 &ek(ix)*bbcu(imbb(i),12)
676 cikveb(j)=-ed(ix)*bbcu(imbb(i),12)+ &
677 &ek(ix)*bbcu(imbb(i),11)
678 endif
679 xrb(j)=abs(crkveb(j))/rb(j)
680 zrb(j)=abs(cikveb(j))/rb(j)
681 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
682 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
683 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
684 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
685 enddo
686 call wzsubv(napx,zrb(1),xrb(1),crzb(1),crxb(1))
687 call wzsubv(napx,zbb(1),xbb(1),cbzb(1),cbxb(1))
688 do j=1,napx
689 beamoff(4,imbb(i))=rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
690 &sign(one,crkveb(j))
691 beamoff(5,imbb(i))=rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
692 &sign(one,cikveb(j))
693 enddo
694 endif
695 endif
696 endif
697 goto 290
698 !--Hirata's 6D beam-beam kick
699 else if(kzz.eq.20.and.parbe(ix,2).gt.0) then
700 ktrack(i)=44
701 parbe(ix,4)=-crad*ptnfac(ix)*half*c1m6
702 if(ibeco.eq.1) then
703 track6d(1,1)=ed(ix)*c1m3
704 track6d(2,1)=zero
705 track6d(3,1)=ek(ix)*c1m3
706 track6d(4,1)=zero
707 track6d(5,1)=zero
708 track6d(6,1)=zero
709 napx0=napx
710 napx=1
711 call beamint(napx,track6d,parbe,sigz,bbcu,imbb(i),ix,ibtyp, &
712 &ibbc)
713 beamoff(1,imbb(i))=track6d(1,1)*c1e3
714 beamoff(2,imbb(i))=track6d(3,1)*c1e3
715 beamoff(4,imbb(i))=track6d(2,1)*c1e3
716 beamoff(5,imbb(i))=track6d(4,1)*c1e3
717 beamoff(6,imbb(i))=track6d(6,1)
718 napx=napx0
719 endif
720 goto 290
721 endif
722 if(kzz.eq.15) then
723 ktrack(i)=45
724 goto 290
725 endif
726 if(kzz.eq.16) then
727 ktrack(i)=51
728 goto 290
729 else if(kzz.eq.-16) then
730 ktrack(i)=52
731 goto 290
732 endif
733 if(kzz.eq.22) then
734 ktrack(i)=3
735 goto 290
736 endif
737 if(mout2.eq.1.and.icextal(i).ne.0) then
738 write(27,'(a16,2x,1p,2d14.6,d17.9)') bez(ix),extalign(i,1), &
739 &extalign(i,2),extalign(i,3)
740 endif
741 if(kzz.lt.0) goto 180
742 goto(50,60,70,80,90,100,110,120,130,140,150),kzz
743 ktrack(i)=31
744 goto 290
745 50 if(abs(smiv(1,i)).le.pieni) then
746 ktrack(i)=31
747 goto 290
748 endif
749 ktrack(i)=11
750 strack(i)=smiv(1,i)*c1e3
751 strackc(i)=strack(i)*tiltc(i)
752 stracks(i)=strack(i)*tilts(i)
753 goto 290
754 60 if(abs(smiv(1,i)).le.pieni.and.abs(ramp(ix)).le.pieni) then
755 ktrack(i)=31
756 goto 290
757 endif
758 ktrack(i)=12
759 strack(i)=smiv(1,i)
760 strackc(i)=strack(i)*tiltc(i)
761 stracks(i)=strack(i)*tilts(i)
762 goto 290
763 70 if(abs(smiv(1,i)).le.pieni) then
764 ktrack(i)=31
765 goto 290
766 endif
767 ktrack(i)=13
768 strack(i)=smiv(1,i)*c1m3
769 strackc(i)=strack(i)*tiltc(i)
770 stracks(i)=strack(i)*tilts(i)
771 goto 290
772 80 if(abs(smiv(1,i)).le.pieni) then
773 ktrack(i)=31
774 goto 290
775 endif
776 ktrack(i)=14
777 strack(i)=smiv(1,i)*c1m6
778 strackc(i)=strack(i)*tiltc(i)
779 stracks(i)=strack(i)*tilts(i)
780 goto 290
781 90 if(abs(smiv(1,i)).le.pieni) then
782 ktrack(i)=31
783 goto 290
784 endif
785 ktrack(i)=15
786 strack(i)=smiv(1,i)*c1m9
787 strackc(i)=strack(i)*tiltc(i)
788 stracks(i)=strack(i)*tilts(i)
789 goto 290
790 100 if(abs(smiv(1,i)).le.pieni) then
791 ktrack(i)=31
792 goto 290
793 endif
794 ktrack(i)=16
795 strack(i)=smiv(1,i)*c1m12
796 strackc(i)=strack(i)*tiltc(i)
797 stracks(i)=strack(i)*tilts(i)
798 goto 290
799 110 if(abs(smiv(1,i)).le.pieni) then
800 ktrack(i)=31
801 goto 290
802 endif
803 ktrack(i)=17
804 strack(i)=smiv(1,i)*c1m15
805 strackc(i)=strack(i)*tiltc(i)
806 stracks(i)=strack(i)*tilts(i)
807 goto 290
808 120 if(abs(smiv(1,i)).le.pieni) then
809 ktrack(i)=31
810 goto 290
811 endif
812 ktrack(i)=18
813 strack(i)=smiv(1,i)*c1m18
814 strackc(i)=strack(i)*tiltc(i)
815 stracks(i)=strack(i)*tilts(i)
816 goto 290
817 130 if(abs(smiv(1,i)).le.pieni) then
818 ktrack(i)=31
819 goto 290
820 endif
821 ktrack(i)=19
822 strack(i)=smiv(1,i)*c1m21
823 strackc(i)=strack(i)*tiltc(i)
824 stracks(i)=strack(i)*tilts(i)
825 goto 290
826 140 if(abs(smiv(1,i)).le.pieni) then
827 ktrack(i)=31
828 goto 290
829 endif
830 ktrack(i)=20
831 strack(i)=smiv(1,i)*c1m24
832 strackc(i)=strack(i)*tiltc(i)
833 stracks(i)=strack(i)*tilts(i)
834 goto 290
835 150 r0=ek(ix)
836 nmz=nmu(ix)
837 if(abs(r0).le.pieni.or.nmz.eq.0) then
838 if(abs(dki(ix,1)).le.pieni.and.abs(dki(ix,2)).le.pieni) then
839 ktrack(i)=31
840 else if(abs(dki(ix,1)).gt.pieni.and.abs(dki(ix,2)).le.pieni) &
841 &then
842 if(abs(dki(ix,3)).gt.pieni) then
843 ktrack(i)=33
844 strack(i)=dki(ix,1)/dki(ix,3)
845 strackc(i)=strack(i)*tiltc(i)
846 stracks(i)=strack(i)*tilts(i)
847 else
848 ktrack(i)=35
849 strack(i)=dki(ix,1)
850 strackc(i)=strack(i)*tiltc(i)
851 stracks(i)=strack(i)*tilts(i)
852 endif
853 else if(abs(dki(ix,1)).le.pieni.and.abs(dki(ix,2)).gt.pieni) &
854 &then
855 if(abs(dki(ix,3)).gt.pieni) then
856 ktrack(i)=37
857 strack(i)=dki(ix,2)/dki(ix,3)
858 strackc(i)=strack(i)*tiltc(i)
859 stracks(i)=strack(i)*tilts(i)
860 else
861 ktrack(i)=39
862 strack(i)=dki(ix,2)
863 strackc(i)=strack(i)*tiltc(i)
864 stracks(i)=strack(i)*tilts(i)
865 endif
866 endif
867 else
868 if(abs(dki(ix,1)).le.pieni.and.abs(dki(ix,2)).le.pieni) then
869 ktrack(i)=32
870 else if(abs(dki(ix,1)).gt.pieni.and.abs(dki(ix,2)).le.pieni) &
871 &then
872 if(abs(dki(ix,3)).gt.pieni) then
873 ktrack(i)=34
874 strack(i)=dki(ix,1)/dki(ix,3)
875 strackc(i)=strack(i)*tiltc(i)
876 stracks(i)=strack(i)*tilts(i)
877 else
878 ktrack(i)=36
879 strack(i)=dki(ix,1)
880 strackc(i)=strack(i)*tiltc(i)
881 stracks(i)=strack(i)*tilts(i)
882 endif
883 else if(abs(dki(ix,1)).le.pieni.and.abs(dki(ix,2)).gt.pieni) &
884 &then
885 if(abs(dki(ix,3)).gt.pieni) then
886 ktrack(i)=38
887 strack(i)=dki(ix,2)/dki(ix,3)
888 strackc(i)=strack(i)*tiltc(i)
889 stracks(i)=strack(i)*tilts(i)
890 else
891 ktrack(i)=40
892 strack(i)=dki(ix,2)
893 strackc(i)=strack(i)*tiltc(i)
894 stracks(i)=strack(i)*tilts(i)
895 endif
896 endif
897 endif
898 if(abs(r0).le.pieni.or.nmz.eq.0) goto 290
899 if(mout2.eq.1) then
900 benkcc=ed(ix)*benkc(irm(ix))
901 r0a=one
902 r000=r0*r00(irm(ix))
903 do 160 j=1,mmul
904 fake(1,j)=bbiv(j,1,i)*r0a/benkcc
905 fake(2,j)=aaiv(j,1,i)*r0a/benkcc
906 160 r0a=r0a*r000
907 write(9,'(a16)') bez(ix)
908 write(9,'(1p,3d23.15)') (fake(1,j), j=1,3)
909 write(9,'(1p,3d23.15)') (fake(1,j), j=4,6)
910 write(9,'(1p,3d23.15)') (fake(1,j), j=7,9)
911 write(9,'(1p,3d23.15)') (fake(1,j), j=10,12)
912 write(9,'(1p,3d23.15)') (fake(1,j), j=13,15)
913 write(9,'(1p,3d23.15)') (fake(1,j), j=16,18)
914 write(9,'(1p,2d23.15)') (fake(1,j), j=19,20)
915 write(9,'(1p,3d23.15)') (fake(2,j), j=1,3)
916 write(9,'(1p,3d23.15)') (fake(2,j), j=4,6)
917 write(9,'(1p,3d23.15)') (fake(2,j), j=7,9)
918 write(9,'(1p,3d23.15)') (fake(2,j), j=10,12)
919 write(9,'(1p,3d23.15)') (fake(2,j), j=13,15)
920 write(9,'(1p,3d23.15)') (fake(2,j), j=16,18)
921 write(9,'(1p,2d23.15)') (fake(2,j), j=19,20)
922 do 170 j=1,20
923 fake(1,j)=zero
924 170 fake(2,j)=zero
925 endif
926 goto 290
927 180 kzz=-kzz
928 goto(190,200,210,220,230,240,250,260,270,280),kzz
929 ktrack(i)=31
930 goto 290
931 190 if(abs(smiv(1,i)).le.pieni) then
932 ktrack(i)=31
933 goto 290
934 endif
935 ktrack(i)=21
936 strack(i)=smiv(1,i)*c1e3
937 strackc(i)=strack(i)*tiltc(i)
938 stracks(i)=strack(i)*tilts(i)
939 goto 290
940 200 if(abs(smiv(1,i)).le.pieni) then
941 ktrack(i)=31
942 goto 290
943 endif
944 ktrack(i)=22
945 strack(i)=smiv(1,i)
946 strackc(i)=strack(i)*tiltc(i)
947 stracks(i)=strack(i)*tilts(i)
948 goto 290
949 210 if(abs(smiv(1,i)).le.pieni) then
950 ktrack(i)=31
951 goto 290
952 endif
953 ktrack(i)=23
954 strack(i)=smiv(1,i)*c1m3
955 strackc(i)=strack(i)*tiltc(i)
956 stracks(i)=strack(i)*tilts(i)
957 goto 290
958 220 if(abs(smiv(1,i)).le.pieni) then
959 ktrack(i)=31
960 goto 290
961 endif
962 ktrack(i)=24
963 strack(i)=smiv(1,i)*c1m6
964 strackc(i)=strack(i)*tiltc(i)
965 stracks(i)=strack(i)*tilts(i)
966 goto 290
967 230 if(abs(smiv(1,i)).le.pieni) then
968 ktrack(i)=31
969 goto 290
970 endif
971 ktrack(i)=25
972 strack(i)=smiv(1,i)*c1m9
973 strackc(i)=strack(i)*tiltc(i)
974 stracks(i)=strack(i)*tilts(i)
975 goto 290
976 240 if(abs(smiv(1,i)).le.pieni) then
977 ktrack(i)=31
978 goto 290
979 endif
980 ktrack(i)=26
981 strack(i)=smiv(1,i)*c1m12
982 strackc(i)=strack(i)*tiltc(i)
983 stracks(i)=strack(i)*tilts(i)
984 goto 290
985 250 if(abs(smiv(1,i)).le.pieni) then
986 ktrack(i)=31
987 goto 290
988 endif
989 ktrack(i)=27
990 strack(i)=smiv(1,i)*c1m15
991 strackc(i)=strack(i)*tiltc(i)
992 stracks(i)=strack(i)*tilts(i)
993 goto 290
994 260 if(abs(smiv(1,i)).le.pieni) then
995 ktrack(i)=31
996 goto 290
997 endif
998 ktrack(i)=28
999 strack(i)=smiv(1,i)*c1m18
1000 strackc(i)=strack(i)*tiltc(i)
1001 stracks(i)=strack(i)*tilts(i)
1002 goto 290
1003 270 if(abs(smiv(1,i)).le.pieni) then
1004 ktrack(i)=31
1005 goto 290
1006 endif
1007 ktrack(i)=29
1008 strack(i)=smiv(1,i)*c1m21
1009 strackc(i)=strack(i)*tiltc(i)
1010 stracks(i)=strack(i)*tilts(i)
1011 goto 290
1012 280 if(abs(smiv(1,i)).le.pieni) then
1013 ktrack(i)=31
1014 goto 290
1015 endif
1016 ktrack(i)=30
1017 strack(i)=smiv(1,i)*c1m24
1018 strackc(i)=strack(i)*tiltc(i)
1019 stracks(i)=strack(i)*tilts(i)
1020 290 continue
1021
1022
1023 do 300 j=1,napx
1024 dpsv1(j)=dpsv(j)*c1e3/(one+dpsv(j))
1025 300 continue
1026 nwri=nwr(3)
1027 if(nwri.eq.0) nwri=numl+numlr+1
1028 if(idp.eq.0.or.ition.eq.0) then
1029 call thin4d(nthinerr)
1030 else
1031 hsy(3)=c1m3*hsy(3)*ition
1032 do 310 jj=1,nele
1033 if(kz(jj).eq.12) hsyc(jj)=c1m3*hsyc(jj)*itionc(jj)
1034 310 continue
1035 if(abs(phas).ge.pieni) then
1036 call thin6dua(nthinerr)
1037 else
1038 open(unit=outlun, file='colltrack.out')
1039 !
1040 write(*,*)
1041 write(*,*) ' -------------------------------'
1042 write(*,*)
1043 write(*,*) ' Program C O L L T R A C K '
1044 write(*,*)
1045 write(*,*) ' R. Assmann - AB/ABP'
1046 write(*,*) ' C. Bracco - AB/ABP'
1047 write(*,*) ' V. Previtali - AB/ABP'
1048 write(*,*) ' S. Redaelli - AB/OP'
1049 write(*,*) ' G. Robert-Demolaize - AB/ABP'
1050 write(*,*) ' T. Weiler - AB/ABP'
1051 write(*,*)
1052 write(*,*) ' CERN 2001 - 2007'
1053 write(*,*)
1054 write(*,*) ' -------------------------------'
1055 write(*,*)
1056 write(*,*)
1057 write(outlun,*)
1058 write(outlun,*)
1059 write(outlun,*) ' -------------------------------'
1060 write(outlun,*)
1061 write(outlun,*) ' Program C O L L T R A C K '
1062 write(outlun,*)
1063 write(outlun,*) ' R. Assmann - AB/ABP'
1064 write(outlun,*) ' C. Bracco - AB/ABP'
1065 write(outlun,*) ' V. Previtali - AB/ABP'
1066 write(outlun,*) ' S. Redaelli - AB/OP'
1067 write(outlun,*) ' G. Robert-Demolaize - AB/ABP'
1068 write(outlun,*) ' T. Weiler - AB/ABP'
1069 write(outlun,*)
1070 write(outlun,*) ' CERN 2001 - 2007'
1071 write(outlun,*)
1072 write(outlun,*) ' -------------------------------'
1073 write(outlun,*)
1074 write(outlun,*)
1075 !
1076 write(*,*)
1077 write(*,*) 'Collimation version of Sixtrack running... 10/2005'
1078 write(*,*)
1079 write(*,*) ' R. Assmann, F. Schmidt, CERN'
1080 write(*,*) ' S. Redaelli, CERN'
1081 write(*,*) ' G. Robert-Demolaize, CERN'
1082 write(*,*)
1083 write(*,*) 'Generating particle distribution at FIRST element!'
1084 write(*,*) 'Optical functions obtained from Sixtrack internal!'
1085 write(*,*) 'Emittance and energy obtained from Sixtrack input!'
1086 write(*,*)
1087 write(*,*)
1088 write(*,*) 'Info: Betax0 [m] ', tbetax(1)
1089 write(*,*) 'Info: Betay0 [m] ', tbetay(1)
1090 write(*,*) 'Info: Alphax0 ', talphax(1)
1091 write(*,*) 'Info: Alphay0 ', talphay(1)
1092 write(*,*) 'Info: Orbitx0 [mm] ', torbx(1)
1093 write(*,*) 'Info: Orbitxp0 [mrad] ', torbxp(1)
1094 write(*,*) 'Info: Orbity0 [mm] ', torby(1)
1095 write(*,*) 'Info: Orbitpy0 [mrad] ', torbyp(1)
1096 write(*,*) 'Info: Emitx0 [um] ', remitx
1097 write(*,*) 'Info: Emity0 [um] ', remity
1098 write(*,*) 'Info: E0 [MeV] ', e0
1099 write(*,*)
1100 write(*,*) 'MYENOM' ,myenom
1101 !
1102 myemitx0 = remitx*1d-6
1103 myemity0 = remity*1d-6
1104 myalphax = talphax(1)
1105 myalphay = talphay(1)
1106 mybetax = tbetax(1)
1107 mybetay = tbetay(1)
1108 ! myenom = e0
1109 !
1110 if (myemitx0.le.0. .or. myemity0.le.0.) then
1111 write(*,*) &
1112 &'ERR> Please use BEAM command to define emittances!'
1113 stop
1114 endif
1115 !
1116 !++ Calculate the gammas
1117 !
1118 mygammax = (1d0+myalphax**2)/mybetax
1119 mygammay = (1d0+myalphay**2)/mybetay
1120 !
1121 !++ Number of points and generate distribution
1122 !
1123 !GRD SEMI-AUTOMATIC INPUT
1124 ! NLOOP=10
1125 ! MYNEX=6.003
1126 ! MYDEX=0.0015
1127 ! MYNEY=6.003
1128 ! MYDEY=0.0015
1129 ! DO_COLL=1
1130 ! NSIG_PRIM=5.
1131 ! NSIG_SEC=6.
1132 rselect=64
1133 !
1134 write(*,*) 'INFO> NLOOP = ', nloop
1135 write(*,*) 'INFO> DO_THISDIS = ', do_thisdis
1136 write(*,*) 'INFO> MYNEX = ', mynex
1137 write(*,*) 'INFO> MYDEX = ', mdex
1138 write(*,*) 'INFO> MYNEY = ', myney
1139 write(*,*) 'INFO> MYDEY = ', mdey
1140 write(*,*) 'INFO> FILENAME_DIS = ', filename_dis
1141 write(*,*) 'INFO> ENERROR = ', enerror
1142 write(*,*) 'INFO> BUNCHLENGTH = ', bunchlength
1143 write(*,*) 'INFO> RSELECT = ', int(rselect)
1144 write(*,*) 'INFO> DO_COLL = ', do_coll
1145 write(*,*) 'INFO> DO_NSIG = ', do_nsig
1146 write(*,*) 'INFO> NSIG_TCP3 = ', nsig_tcp3
1147 write(*,*) 'INFO> NSIG_TCSG3 = ', nsig_tcsg3
1148 write(*,*) 'INFO> NSIG_TCSM3 = ', nsig_tcsm3
1149 write(*,*) 'INFO> NSIG_TCLA3 = ', nsig_tcla3
1150 write(*,*) 'INFO> NSIG_TCP7 = ', nsig_tcp7
1151 write(*,*) 'INFO> NSIG_TCSG7 = ', nsig_tcsg7
1152 write(*,*) 'INFO> NSIG_TCSM7 = ', nsig_tcsm7
1153 write(*,*) 'INFO> NSIG_TCLA7 = ', nsig_tcla7
1154 write(*,*) 'INFO> NSIG_TCLP = ', nsig_tclp
1155 write(*,*) 'INFO> NSIG_TCLI = ', nsig_tcli
1156 ! write(*,*) 'INFO> NSIG_TCTH = ', nsig_tcth
1157 ! write(*,*) 'INFO> NSIG_TCTV = ', nsig_tctv
1158 write(*,*) 'INFO> NSIG_TCTH1 = ', nsig_tcth1
1159 write(*,*) 'INFO> NSIG_TCTV1 = ', nsig_tctv1
1160 write(*,*) 'INFO> NSIG_TCTH2 = ', nsig_tcth2
1161 write(*,*) 'INFO> NSIG_TCTV2 = ', nsig_tctv2
1162 write(*,*) 'INFO> NSIG_TCTH5 = ', nsig_tcth5
1163 write(*,*) 'INFO> NSIG_TCTV5 = ', nsig_tctv5
1164 write(*,*) 'INFO> NSIG_TCTH8 = ', nsig_tcth8
1165 write(*,*) 'INFO> NSIG_TCTV8 = ', nsig_tctv8
1166 !
1167 write(*,*) 'INFO> NSIG_TCDQ = ', nsig_tcdq
1168 write(*,*) 'INFO> NSIG_TCSTCDQ = ', nsig_tcstcdq
1169 write(*,*) 'INFO> NSIG_TDI = ', nsig_tdi
1170 write(*,*) 'INFO> NSIG_TCXRP = ', nsig_tcxrp
1171 write(*,*) 'INFO> NSIG_TCRYP = ', nsig_tcryo
1172 write(*,*) 'INFO> NSIG_CRY = ', nsig_cry
1173 !
1174 write(*,*)
1175 write(*,*) 'INFO> INPUT PARAMETERS FOR THE SLICING:'
1176 write(*,*)
1177 write(*,*) 'INFO> N_SLICES = ', n_slices
1178 write(*,*) 'INFO> SMIN_SLICES = ',smin_slices
1179 write(*,*) 'INFO> SMAX_SLICES = ',smax_slices
1180 write(*,*) 'INFO> RECENTER1 = ',recenter1
1181 write(*,*) 'INFO> RECENTER2 = ',recenter2
1182 write(*,*)
1183 write(*,*) 'INFO> FIT1_1 = ',fit1_1
1184 write(*,*) 'INFO> FIT1_2 = ',fit1_2
1185 write(*,*) 'INFO> FIT1_3 = ',fit1_3
1186 write(*,*) 'INFO> FIT1_4 = ',fit1_4
1187 write(*,*) 'INFO> FIT1_5 = ',fit1_5
1188 write(*,*) 'INFO> FIT1_6 = ',fit1_6
1189 write(*,*) 'INFO> SCALING1 = ',ssf1
1190 write(*,*)
1191 write(*,*) 'INFO> FIT2_1 = ',fit2_1
1192 write(*,*) 'INFO> FIT2_2 = ',fit2_2
1193 write(*,*) 'INFO> FIT2_3 = ',fit2_3
1194 write(*,*) 'INFO> FIT2_4 = ',fit2_4
1195 write(*,*) 'INFO> FIT2_5 = ',fit2_5
1196 write(*,*) 'INFO> FIT2_6 = ',fit2_6
1197 write(*,*) 'INFO> SCALING2 = ',ssf2
1198 write(*,*)
1199 !
1200 ! HERE WE CHECK IF THE NEW INPUT IS READ CORRECTLY
1201 !
1202 write(*,*) 'INFO> EMITX0 = ', emitx0
1203 write(*,*) 'INFO> EMITY0 = ', emity0
1204 write(*,*)
1205 write(*,*) 'INFO> DO_SELECT = ', do_select
1206 write(*,*) 'INFO> DO_NOMINAL = ', do_nominal
1207 write(*,*) 'INFO> RND_SEED = ', rnd_seed
1208 write(*,*) 'INFO> DOWRITE_DIST = ', dowrite_dist
1209 write(*,*) 'INFO> NAME_SEL = ', name_sel
1210 write(*,*) 'INFO> DO_ONESIDE = ', do_oneside
1211 write(*,*) 'INFO> DOWRITE_IMPACT = ', dowrite_impact
1212 write(*,*) 'INFO> DOWRITE_SECONDARY = ', dowrite_secondary
1213 write(*,*) 'INFO> DOWRITE_AMPLITUDE = ', dowrite_amplitude
1214 write(*,*)
1215 write(*,*) 'INFO> XBEAT = ', xbeat
1216 write(*,*) 'INFO> XBEATPHASE = ', xbeatphase
1217 write(*,*) 'INFO> YBEAT = ', ybeat
1218 write(*,*) 'INFO> YBEATPHASE = ', ybeatphase
1219 write(*,*)
1220 write(*,*) 'INFO> C_RMSTILT_PRIM = ', c_rmstilt_prim
1221 write(*,*) 'INFO> C_RMSTILT_SEC = ', c_rmstilt_sec
1222 write(*,*) 'INFO> C_SYSTILT_PRIM = ', c_systilt_prim
1223 write(*,*) 'INFO> C_SYSTILT_SEC = ', c_systilt_sec
1224 write(*,*) 'INFO> C_RMSOFFSET_PRIM = ', c_rmsoffset_prim
1225 write(*,*) 'INFO> C_SYSOFFSET_PRIM = ', c_sysoffset_prim
1226 write(*,*) 'INFO> C_RMSOFFSET_SEC = ', c_rmsoffset_sec
1227 write(*,*) 'INFO> C_SYSOFFSET_SEC = ', c_sysoffset_sec
1228 write(*,*) 'INFO> C_OFFSETTITLT_SEED = ', c_offsettilt_seed
1229 write(*,*) 'INFO> C_RMSERROR_GAP = ', c_rmserror_gap
1230 write(*,*) 'INFO> DO_MINGAP = ', do_mingap
1231 write(*,*)
1232 write(*,*) 'INFO> RADIAL = ', radial
1233 write(*,*) 'INFO> NR = ', nr
1234 write(*,*) 'INFO> NDR = ', ndr
1235 write(*,*)
1236 write(*,*) 'INFO> DRIFTSX = ', driftsx
1237 write(*,*) 'INFO> DRIFTSY = ', driftsy
1238 write(*,*) 'INFO> CUT_INPUT = ', cut_input
1239 write(*,*) 'INFO> SYSTILT_ANTISYMM = ', systilt_antisymm
1240 write(*,*)
1241 write(*,*) 'INFO> IPENCIL = ', ipencil
1242 write(*,*) 'INFO> PENCIL_OFFSET = ', pencil_offset
1243 write(*,*) 'INFO> PENCIL_RMSX = ', pencil_rmsx
1244 write(*,*) 'INFO> PENCIL_RMSY = ', pencil_rmsy
1245 write(*,*) 'INFO> PENCIL_DISTR = ', pencil_distr
1246 write(*,*)
1247 write(*,*) 'INFO> COLL_DB = ', coll_db
1248 write(*,*) 'INFO> IBEAM = ', ibeam
1249 write(*,*)
1250 write(*,*) 'INFO> DOWRITETRACKS = ', dowritetracks
1251 write(*,*)
1252 write(*,*) 'INFO> CERN = ', cern
1253 write(*,*)
1254 write(*,*) 'INFO> CASTORDIR = ', castordir
1255 write(*,*)
1256 write(*,*) 'INFO> JOBNUMBER = ', jobnumber
1257 write(*,*)
1258 write(*,*) 'INFO> CUTS = ', sigsecut2, sigsecut3
1259 write(*,*)
1260 !
1261 mynp = nloop*napx
1262 !
1263 napx00 = napx
1264 !
1265 write(*,*) 'INFO> NAPX = ', napx, mynp
1266 write(*,*) 'INFO> Sigma_x0 = ', sqrt(mybetax*myemitx0)
1267 write(*,*) 'INFO> Sigma_y0 = ', sqrt(mybetay*myemity0)
1268 !
1269 ! HERE WE SET THE MARKER FOR INITIALIZATION:
1270 !
1271 firstrun = .true.
1272 !
1273 ! ...and here is implemented colltrack's beam distribution:
1274 !
1275 !
1276 !++ Initialize random number generator
1277 !
1278 if (rnd_seed.eq.0) rnd_seed = mclock_liar()
1279 if (rnd_seed.lt.0) rnd_seed = abs(rnd_seed)
1280 rnd_lux = 3
1281 rnd_k1 = 0
1282 rnd_k2 = 0
1283 call rluxgo(rnd_lux, rnd_seed, rnd_k1, rnd_k2)
1284 CALL RNDMST(12,34,56,78)
1285 write(*,*)
1286 write(outlun,*) 'INFO> rnd_seed: ', rnd_seed
1287 !Call distribution routines only if collimation block is in fort.3, otherwise
1288 !the standard sixtrack would be prevented by the 'stop' command
1289 if(do_coll) then
1290 if (radial) then
1291 call makedis_radial(mynp, myalphax, myalphay, mybetax,
1292 & mybetay, myemitx0, myemity0, myenom, nr, ndr,
1293 & myx, myxp, myy, myyp, myp, mys)
1294 else
1295 if (do_thisdis.eq.1) then
1296 call makedis(mynp, myalphax, myalphay, mybetax, mybetay,
1297 & myemitx0, myemity0, myenom, mynex, mdex, myney, mdey,
1298 & myx, myxp, myy, myyp, myp, mys)
1299 elseif(do_thisdis.eq.2) then
1300 call makedis_st(mynp, myalphax, myalphay, mybetax, mybetay,
1301 & myemitx0, myemity0, myenom, mynex, mdex, myney, mdey,
1302 & myx, myxp, myy, myyp, myp, mys)
1303 elseif(do_thisdis.eq.3) then
1304 call makedis_de(mynp, myalphax, myalphay, mybetax, mybetay,
1305 & myemitx0, myemity0, myenom, mynex, mdex, myney, mdey,
1306 & myx, myxp, myy, myyp, myp, mys,enerror,bunchlength)
1307 elseif(do_thisdis.eq.4) then
1308 call readdis(filename_dis,
1309 & mynp, myx, myxp, myy, myyp, myp, mys)
1310 else
1311 write(*,*) 'INFO> review your distribution parameters !!'
1312 stop
1313 endif
1314 !
1315 endif
1316 !
1317 endif
1318 !++ Reset distribution for pencil beam
1319 !
1320 if (ipencil.gt.0) then
1321 write(*,*) 'WARN> Distributions reset to pencil beam!'
1322 write(*,*)
1323 write(outlun,*) 'WARN> Distributions reset to pencil beam!'
1324 do j = 1, mynp
1325 myx(j) = 0d0
1326 myxp(j) = 0d0
1327 myy(j) = 0d0
1328 myyp(j) = 0d0
1329 end do
1330 endif
1331 !
1332 !++ Optionally write the generated particle distribution
1333 !
1334 open(unit=52,file='dist0.dat')
1335 if (dowrite_dist) then
1336 write(52,*)"1=x 2=xp 3=y 4=yp 5=s 6=p 7=x_norm 8=xp_norm
1337 1 9=y_norm 10=yp_norm 11=Ax 12=Ay 13=iname"
1338 do j = 1, mynp
1339 write(52,'(12(1X,E15.7),a)') myx(j), myxp(j), myy(j), myyp(j),
1340 & mys(j), myp(j), (myx(j)/sqrt(myemitx0*mybetax)),
1341 & (myx(j)*myalphax+myxp(j)*mybetax)/sqrt(myemitx0*mybetax),
1342 & (myy(j)/sqrt(myemity0*mybetay)),
1343 & (myy(j)*myalphay+myyp(j)*mybetay)/sqrt(myemity0*mybetay),
1344 & sqrt( ((myx(j)/sqrt(myemitx0*mybetax)))**2 +
1345 & ( (myx(j)*myalphax+myxp(j)*mybetax)/sqrt(myemitx0*mybetax))**2 ),
1346 & sqrt( ((myy(j)/sqrt(myemity0*mybetay)) )**2+
1347 & ( (myy(j)*myalphay+myyp(j)*mybetay)/sqrt(myemity0*mybetay) )**2 )
1348 end do
1349 endif
1350 close(52)
1351 !
1352 !++ Initialize efficiency array
1353 !
1354 do i = 1, mynp
1355 part_hit(i) = 0
1356 part_abs(i) = 0
1357 part_select(i) = 1
1358 part_indiv(i) = -1d-6
1359 part_linteract(i) = 0d0
1360 part_hit_before(i) = 0
1361 tertiary(i) = 0
1362 secondary(i) = 0
1363 other(i) = 0
1364 x00(i) = myx(i)
1365 xp00(i) = myxp(i)
1366 y00(i) = myy(i)
1367 yp00(i) = myyp(i)
1368 end do
1369 !
1370 do i=1,iu
1371 sum_ax(i) = 0d0
1372 sqsum_ax(i) = 0d0
1373 sum_ay(i) = 0d0
1374 sqsum_ay(i) = 0d0
1375 nampl(i) = 0d0
1376 sampl(i) = 0d0
1377 end do
1378 !
1379 nspx = 0d0
1380 nspy = 0d0
1381
1382 np0 = mynp
1383 !
1384 ax0 = myalphax
1385 bx0 = mybetax
1386 mux0 = mux(1)
1387 ay0 = myalphay
1388 by0 = mybetay
1389 muy0 = muy(1)
1390 iturn = 1
1391 ie = 1
1392 n_tot_absorbed = 0
1393 !
1394 !===============================================================================
1395 !Ralph make loop over 1e6/napx, a read xv(1,j) etc
1396 !Du solltest zur Sicherheit dies resetten bevor Du in thin6d gehst
1397 !Im Falle von Teilchenverluste werden n mlich pstop und nnumxv umgesetzt
1398 ! do 80 i=1,npart
1399 ! pstop(i)=.false.
1400 ! nnumxv(i)=numl
1401 ! 80 numxv(i)=numl
1402 !===============================================================================
1403
1404
1405 open(unit=42, file='beta_beat.dat')
1406 write(42,*) &
1407 &'# 1=s 2=bx/bx0 3=by/by0 4=sigx0 5=sigy0 6=crot 7=acalc'
1408 write(42,*) j
1409
1410 open(unit=43, file='collgaps.dat')
1411
1412 open(unit=44, file='survival.dat')
1413 write(44,*) &
1414 &'# 1=turn 2=n_particle 3=sample_number'
1415 !
1416 open(unit=40, file='collimator-temp.db')
1417 if(firstrun) write(43,*) &
1418 &'# ID name angle[rad] betax[m] betay[m] ', &
1419 &'halfgap[m] Material Length[m] sigx[m] sigy[m] ', &
1420 &'tilt1[rad] tilt2[rad] nsig'
1421
1422 open(unit=55, file='collsettings.dat')
1423 if(firstrun) write(55,*) &
1424 &'# name slicenumber halfgap[m] gap_offset[m] ', &
1425 &'tilt jaw1[rad] tilt jaw2[rad] length[m] material' &
1426
1427 if (dowrite_impact) then
1428 open(unit=49,file='impact.dat')
1429 if(firstrun) write(49,*) &
1430 &'# 1=impact 2=divergence'
1431 endif
1432
1433 !SEPT 2007 valentina : open (if set write_c_out) special outputs for crystal
1434 if (write_c_out) then
1435 OPEN(UNIT=881,FILE='cry_entrance.dat')
1436 WRITE(881,'(a)')
1437 1 '# ipart nturn last_proc icoll coll_mat x[m] xp[rad]
1438 2 y[m] yp[rad] p[GeV]'
1439 c
1440 OPEN(UNIT=882,FILE='cry_exit.dat')
1441 WRITE(882,'(a)')
1442 1 '#ipart nturn last_proc proc icoll coll_mat x[m]
1443 2xp[rad] y[m] yp[rad] p[GeV]'
1444 c
1445 OPEN(UNIT=883,FILE='cry_entrance_norm.dat')
1446 WRITE(883,'(a)')
1447 1 '#ipart nturn last_proc icoll coll_mat x[m] xp[rad]
1448 2 y[m] yp[rad] n_ampl-X[sig] n_ampl-Y[sig]
1449 3 p[GeV]'
1450
1451 OPEN(UNIT=884,FILE='cry_exit_norm.dat')
1452 WRITE(884,'(a)')
1453 1 '#ipart interaction? last_proc proc nturn icoll coll_mat x[m]
1454 2 xp[rad] y[m] yp[rad] n_ampl-X[sig]
1455 3 n_ampl-Y[sig] p[GeV]'
1456 !
1457 OPEN(UNIT=885,FILE='kick.dat')
1458 write(885,'(a)')
1459 & '#1=ipart 2=nturn 3=last_proc 4=proc 5=icoll 6=coll_mat 7=x[m]
1460 & 8=xp[rad] 9=y[m] 10=yp[rad] 11=kickx[rad] 12=kicky[rad]
1461 & 13=Deltap[GeV] 14=aperture 15=tilt '
1462 !
1463 OPEN(UNIT=833,FILE='cr_par_check.dat')
1464 open(unit=866,file='cr_process.dat')
1465 c open(unit=9999,file='debug.dat')
1466
1467 endif
1468
1469 c#########################################################################
1470 C beginning of the loop on the particle samples (closes @~1820)
1471 c########################################################################
1472
1473 do j = 1, int(mynp/napx00)
1474 !
1475 write(*,*) 'Sample number ', j, int(mynp/napx00)
1476 samplenumber=j
1477 !
1478 !
1479 ! HERE WE OPEN ALL THE NEEDED OUTPUT FILES
1480 !
1481 ! TW06/08 added ouputfile for real collimator settings (incluing slicing, ...)
1482 ! TW06/08
1483 !
1484 !APRIL2005
1485 c---------------
1486 if (dowritetracks) then
1487 c
1488 if (cern) then
1489 pfile(1:8) = 'tracks2.'
1490 c
1491 if(samplenumber.le.9) then
1492 pfile(9:9) = smpl
1493 pfile(10:13) = '.dat'
1494 elseif(samplenumber.gt.9.and.samplenumber.le.99) then
1495 pfile(9:10) = smpl
1496 pfile(11:14) = '.dat'
1497 elseif(samplenumber.gt.99.and. &
1498 &samplenumber.le.int(mynp/napx00)) then
1499 pfile(9:11) = smpl
1500 pfile(12:15) = '.dat'
1501 endif
1502 c
1503 if(samplenumber.le.9) &
1504 &open(unit=38,file=pfile(1:13))
1505 if(samplenumber.gt.9.and.samplenumber.le.99) &
1506 &open(unit=38,file=pfile(1:14))
1507 c
1508 if(samplenumber.gt.99.and. &
1509 &samplenumber.le.int(mynp/napx00)) &
1510 &open(unit=38,file=pfile(1:15))
1511 else
1512 open(unit=38,file='tracks2.dat')
1513 !
1514 endif !close if(cern)
1515 c
1516 if(firstrun) write(38,*) &
1517 &'# 1=name 2=turn 3=s 4=x 5=xp 6=y 7=yp 8=DE/E 9=type'
1518 c
1519 endif !close if(dowritetracks)
1520
1521 c
1522 !AUGUST2006:write pencul sheet beam coordiantes to file ---- TW
1523 open(unit=9997, file='pencilbeam_distr.dat')
1524 if(firstrun) write(9997,*) 'x xp y yp'
1525 if(do_select) then
1526 open(unit=45, file='coll_ellipse.dat')
1527 if (firstrun) then
1528 write(45,'(a)') &
1529 & '# 1=x 2=y 3=xp 4=yp 5=E 6=s 7=turn 8=xnorm 9=ynorm &
1530 & 10=xpnorm 11=xpnorm 12=ampl_x 13=ampl_y'
1531 c write(9999,'(a)') &
1532 c & '# 1=x 2=y 3=xp 4=yp 5=E 6=s 7=turn 8=xnorm 9=ynorm &
1533 c & 10=xpnorm 11=xpnorm 12=ampl_x 13=ampl_y'
1534 endif
1535 endif
1536 if(dowrite_impact) then
1537 open(unit=46, file='all_impacts.dat')
1538 open(unit=47, file='all_absorptions.dat')
1539 open(unit=48, file='FLUKA_impacts.dat')
1540 open(unit=39, file='FirstImpacts.dat')
1541 if (firstrun) then
1542 write(46,'(a)') '# 1=name 2=turn 3=s'
1543 write(47,'(a)') '# 1=name 2=turn 3=s'
1544 write(48,'(a)') &
1545 &'# 1=icoll 2=c_rotation 3=s 4=x 5=xp 6=y 7=yp 8=nabs 9=np 10=turn'
1546 write(39,*) &
1547 & '%1=name,2=iturn, 3=icoll, 4=nabs, 5=s_imp[m], 6=s_out[m], ',&
1548 & '7=x_in(b!)[m], 8=xp_in, 9=y_in, 10=yp_in, ', &
1549 & '11=x_out [m], 12=xp_out, 13=y_out, 14=yp_out'
1550 write(866,'(a)') &
1551 & '%1=name,2=iturn, 3=icoll, 4=cr_process'
1552 endif
1553 endif
1554 if(name_sel(1:3).eq.'COL') then
1555 open(unit=555, file='RHIClosses.dat')
1556 if(firstrun) write(555,'(a)') &
1557 &'# 1=name 2=turn 3=s 4=x 5=xp 6=y 7=yp 8=dp/p 9=type'
1558 endif
1559 !
1560 !FOR FAST TRACKING CHECKS AND MULTIPLE SAMPLES
1561 ! open(unit=999,file='checkturns.dat')
1562 !
1563 !++ Reset this as advised by Frank
1564 !
1565 ! do 80 i=1,npart
1566 ! pstop(i)=.false.
1567 ! nnumxv(i)=numl
1568 ! 80 numxv(i)=numl
1569 !
1570 !++ Copy new particles to tracking arrays. Also add the orbit offset at
1571 !++ start of ring!
1572 !
1573 do i = 1, napx00
1574 xv(1,i) = 1e3*myx(i+(j-1)*napx00) +torbx(1)
1575 yv(1,i) = 1e3*myxp(i+(j-1)*napx00) +torbxp(1)
1576 xv(2,i) = 1e3*myy(i+(j-1)*napx00) +torby(1)
1577 yv(2,i) = 1e3*myyp(i+(j-1)*napx00) +torbyp(1)
1578 x00(i) = xv(1,i)
1579 xp00(i) = yv(1,i)
1580 y00(i) = xv(2,i)
1581 yp00(i) = yv(2,i)
1582 !JULY2005 assignation of the proper bunch length
1583 sigmv(i) = mys(i+(j-1)*napx00)
1584 ejv(i) = myp(i+(j-1)*napx00)
1585 !
1586 !GRD FOR NOT FAST TRACKING ONLY
1587 ejfv(i)=sqrt(ejv(i)*ejv(i)-pma*pma)
1588 rvv(j)=(ejv(i)*e0f)/(e0*ejfv(i))
1589 dpsv(i)=(ejfv(i)-e0f)/e0f
1590 oidpsv(i)=one/(one+dpsv(i))
1591 dpsv1(i)=dpsv(i)*c1e3*oidpsv(i)
1592 !GRD
1593 !APRIL2005
1594 ! dpsv(i) = 0d0
1595 absorbed(i) = 0
1596 do ieff =1, numeff
1597 counted_r(i,ieff) = 0
1598 counted_x(i,ieff) = 0
1599 counted_y(i,ieff) = 0
1600 end do
1601 !GRD INITIALIZE MAX COUNTERS
1602 ieffmax_r(i) = 0
1603 ieffmax_x(i) = 0
1604 ieffmax_y(i) = 0
1605 end do
1606 !
1607 !
1608 !++ Thin lens tracking
1609 !
1610 !
1611 call thin6d(nthinerr)
1612 !
1613 !
1614 if(dowritetracks) then
1615 if(cern) close(38)
1616 endif
1617 !------------------------------------------------------------------------
1618 !++ Write the number of absorbed particles
1619 !
1620 write(outlun,*) 'INFO> Number of impacts : ', &
1621 ! &N_TOT_ABSORBED+NSURVIVE
1622 &n_tot_absorbed+nsurvive_end
1623 write(outlun,*) 'INFO> Number of impacts at selected : ', &
1624 &num_selhit
1625 write(outlun,*) 'INFO> Number of surviving particles : ', &
1626 ! &NSURVIVE
1627 &nsurvive_end
1628 write(outlun,*) 'INFO> Number of absorbed particles : ', &
1629 &n_tot_absorbed
1630 !
1631 write(outlun,*)
1632 !GRD UPGRADE JANUARY 2005
1633 if(n_tot_absorbed.ne.0d0) then
1634 !
1635 write(outlun,*) ' INFO> Eff_r @ 8 sigma [e-4] : ', &
1636 &neff(5)/dble(n_tot_absorbed)/1d-4
1637 write(outlun,*) ' INFO> Eff_r @ 10 sigma [e-4] : ', &
1638 &neff(9)/dble(n_tot_absorbed)/1d-4
1639 write(outlun,*) ' INFO> Eff_r @ 10-20 sigma [e-4] : ', &
1640 &(neff(9)-neff(19))/(dble(n_tot_absorbed))/1d-4
1641 !
1642 write(outlun,*)
1643 write(outlun,*) neff(5)/dble(n_tot_absorbed), &
1644 &neff(9)/dble(n_tot_absorbed), &
1645 &(neff(9)-neff(19))/(dble(n_tot_absorbed)), ' !eff'
1646 write(outlun,*)
1647 !
1648 !UPGRADE JANUARY 2005
1649 else
1650 write(*,*) 'NO PARTICLE ABSORBED'
1651 endif
1652 !
1653 !----
1654 write(*,*)
1655 write(*,*) 'INFO> Number of impacts : ', &
1656 &n_tot_absorbed+nsurvive_end
1657 write(*,*) 'INFO> Number of impacts at selected : ', &
1658 &num_selhit
1659 write(*,*) 'INFO> Number of surviving particles : ', &
1660 &nsurvive_end
1661 write(*,*) 'INFO> Number of absorbed particles : ', &
1662 &n_tot_absorbed
1663 write(*,*)
1664 if(n_tot_absorbed.ne.0d0) then
1665 write(*,*) ' INFO> Eff_r @ 8 sigma [e-4] : ', &
1666 &neff(5)/dble(n_tot_absorbed)/1d-4
1667 write(*,*) ' INFO> Eff_r @ 10 sigma [e-4] : ', &
1668 &neff(9)/dble(n_tot_absorbed)/1d-4
1669 write(*,*) ' INFO> Eff_r @ 10-20 sigma [e-4] : ', &
1670 &(neff(9)-neff(19))/(dble(n_tot_absorbed))/1d-4
1671 write(*,*)
1672 else
1673 write(*,*) 'NO PARTICLE ABSORBED'
1674 endif
1675 !
1676 !********************************************************************
1677 ! THIS IS THE END OF THE 'DO' LOOP OVER THE thin6d SUBROUTINE !!!!!
1678 !********************************************************************
1679 end do
1680 !
1681 !------------------------------------------------------------------------
1682 !++ Write efficiency file
1683 !
1684 open(unit=99, file='efficiency.dat')
1685 if(n_tot_absorbed.ne.0d0) then
1686 write(99,*) &
1687 &'# 1=rad_sigma 2=frac_x 3=frac_y 4=frac_r'
1688 do k=1,numeff
1689 write(99,'(7(1x,e15.7),1x,I5)') rsig(k), &
1690 &neffx(k)/dble(n_tot_absorbed), &
1691 &neffy(k)/dble(n_tot_absorbed), &
1692 &neff(k)/dble(n_tot_absorbed), &
1693 &neffx(k), &
1694 &neffy(k), &
1695 &neff(k), n_tot_absorbed
1696 end do
1697 else
1698 write(*,*) 'NO PARTICLE ABSORBED'
1699 endif
1700 close(99)
1701 !------------------------------------------------------------------------
1702 !++ Write collimation summary file
1703 !
1704 open(unit=50, file='coll_summary.dat')
1705
1706 write(50,*) &
1707 &'# 1=icoll 2=nimp 3=nabs 4=imp_av 5=imp_sig 6=length'
1708 do icoll = 1, db_ncoll
1709 if(db_length(icoll).gt.0d0) then
1710 write(50,'(i4,1x,a,2(1x,i5),2(1x,e15.7),3x,f13.10)') &
1711 &icoll, db_name1(icoll),cn_impact(icoll), cn_absorbed(icoll), &
1712 &caverage(icoll), csigma(icoll),db_length(icoll)
1713 endif
1714 end do
1715 close(50)
1716 !-------------------------------------------------------------------------
1717 !GRD
1718 close(outlun)
1719 close(40)
1720 close(42)
1721 close(43)
1722 close(44)
1723 if(dowrite_impact) close(49)
1724 !SEPT2008 valentina: close special cry outputs
1725 c close(9999) !close the debug file
1726 if (write_c_out) then
1727 CLOSE(881) !valentina
1728 CLOSE(882) !valentina
1729 CLOSE(883) !valentina
1730 CLOSE(884) !valentina
1731 CLOSE(885) !valentina
1732 close(833)
1733 endif
1734
1735 if(dowritetracks) then
1736 if(.not. cern) close(38)
1737 if(name_sel(1:3).eq.'COL') close(555)
1738
1739 endif
1740
1741 if(do_select) then
1742 close(45)
1743 endif
1744 if(dowrite_impact) then
1745 close(46)
1746 close(46)
1747 close(47)
1748 close(48)
1749 close(39)
1750
1751 close(866)
1752 endif
1753 !
1754 !
1755 !++ End of Ralph's own little loop
1756 !
1757 !=============================================================================
1758 endif
1759 endif
1760 !
1761 open(unit=56, file='amplitude.dat')
1762 open(unit=51, file='amplitude2.dat')
1763 open(unit=57, file='betafunctions.dat')
1764
1765 if(dowrite_amplitude) then
1766 write(56,*) &
1767 &'# 1=ielem 2=name 3=s 4=AX_AV 5=AX_RMS 6=AY_AV 7=AY_RMS', &
1768 &'8=alphax 9=alphay 10=betax 11=betay 12=orbitx', &
1769 &'13=orbity 14=tdispx 15=tdispy', &
1770 &'16=xbob 17=ybob 18=xpbob 19=ypbob'
1771 do i=1,iu
1772 write(56,'(i4, (1x,a16), 17(1x,e20.13))') &
1773 &i, ename(i), sampl(i), &
1774 &sum_ax(i)/max(nampl(i),1), &
1775 &sqrt(abs((sqsum_ax(i)/max(nampl(i),1))- &
1776 &(sum_ax(i)/max(nampl(i),1))**2)), &
1777 &sum_ay(i)/max(nampl(i),1), &
1778 &sqrt(abs((sqsum_ay(i)/max(nampl(i),1))- &
1779 &(sum_ay(i)/max(nampl(i),1))**2)), &
1780 &talphax(i), talphay(i), &
1781 &tbetax(i), tbetay(i), torbx(i), torby(i), &
1782 &tdispx(i), tdispy(i), &
1783 &xbob(i),ybob(i),xpbob(i),ypbob(i)
1784 end do
1785 write(51,*) &
1786 &'# 1=ielem 2=name 3=s 4=ORBITX 5=orbity 6=orbxp 7=orbyp 8=tdispx 9
1787 &=tdispy 10=x_norm 11=y_norm 12=xp_norm 13=yp_norm 14=nx 15=ny'
1788
1789 do i=1,iu
1790 write(51,*)
1791 &i, ename(i), sampl(i), &
1792 &torbx(i), torby(i),
1793 &torbxp(i),torbyp(i),
1794 &tdispx(i), tdispy(i), &
1795 &xdebugN(i),ydebugN(i),xpdebugN(i),ypdebugN(i),
1796 &sqrt(xdebugN(i)**2+xpdebugN(i)**2),
1797 &sqrt(ydebugN(i)**2+ypdebugN(i)**2)
1798
1799 end do
1800
1801 write(57,*) &
1802 &'# 1=ielem 2=name 3=s 4=TBETAX 5=TBETAY'
1803 do i=1,iu
1804 write(57,'(i4, (1x,a16), 3(1x,e15.7))') &
1805 &i, ename(i), sampl(i), &
1806 &tbetax(i), tbetay(i)
1807 end do
1808 endif
1809 close(56)
1810 close(51)
1811 close(57)
1812 open(unit=99, file='orbitchecking.dat')
1813 write(99,*) '# 1=s 2=torbitx 3=torbity'
1814 do j=1,iu
1815 write(99,'(i4, 3(1x,e15.7))') &
1816 &j, sampl(j),torbx(j), torby(j)
1817 end do
1818 close(99)
1819 return
1820 end
1821 subroutine thin4d(nthinerr)
1822 !-----------------------------------------------------------------------
1823 !
1824 ! TRACK THIN LENS 4D
1825 !
1826 !
1827 ! F. SCHMIDT
1828 !-----------------------------------------------------------------------
1829 implicit none
1830 integer i,irrtr,ix,j,k,kpz,n,nmz,nthinerr
1831 double precision cbxb,cbzb,cccc,cikve,cikveb,crkve,crkveb,crkveuk,&
1832 &crxb,crzb,dpsv3,pux,r0,r2b,rb,rho2b,rkb,stracki,tkb,xbb,xlvj,xrb, &
1833 &yv1j,yv2j,zbb,zlvj,zrb
1834 integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1, &
1835 &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran, &
1836 &nrco,ntr,nzfz
1837 parameter(npart = 64,nmac = 1)
1838 parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000, &
1839 &nzfz = 300000,mmul = 11)
1840 parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5, &
1841 &nema = 15)
1842 parameter(mcor = 10,mcop = mcor+6, mbea = 15)
1843 parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
1844 parameter(nmon1 = 600,ncor1 = 600)
1845 parameter(ntr = 20,nbb = 160)
1846 integer ireturn, xory, nac, nfree, nramp1,nplato, nramp2
1847 double precision e0fo,e0o,xv1j,xv2j
1848 double precision acdipamp, qd, acphase, acdipamp2, &
1849 &acdipamp1
1850 double precision l,cur,dx,dy,tx,ty,embl,leff,rx,ry,lin,chi,xi,yi
1851 logical llost
1852 double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3, &
1853 &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21, &
1854 &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
1855 &one,pieni,pmae,pmap,three,two,zero
1856 parameter(pieni = 1d-38)
1857 parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
1858 parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
1859 parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
1860 parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
1861 parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 = &
1862 &1.0d16)
1863 parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
1864 parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
1865 parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
1866 parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
1867 parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
1868 parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
1869 parameter(pmap = 938.271998d0,pmae = .510998902d0)
1870 parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
1871 integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo, &
1872 &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor, &
1873 &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb, &
1874 &imc,imtr,iorg,iout, &
1875 &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires, &
1876 &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw, &
1877 &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox, &
1878 &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo, &
1879 &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx, &
1880 &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr, &
1881 &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew, &
1882 &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr, &
1883 &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
1884 double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu, &
1885 &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
1886 &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft, &
1887 &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
1888 &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign, &
1889 &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum, &
1890 &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
1891 &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph, &
1892 &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
1893 &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel, &
1894 &acdipph
1895 real hmal
1896 character*16 bez,bezb,bezr,erbez,bezl
1897 character*80 toptit,sixtit,commen
1898 common/erro/ierro,erbez
1899 common/kons/pi,pi2,pisqrt,rad
1900 common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
1901 common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
1902 common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
1903 common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
1904 common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
1905 common/syos2/rvf(mpa)
1906 common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
1907 &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
1908 common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3), &
1909 &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen, &
1910 &iicav,itionc(nele),ition,idp,ncy,ixcav
1911 common/corcom/dpscor,sigcor,icode,idam,its6d
1912 common/multi/bk0(nele,mmul),ak0(nele,mmul), &
1913 &bka(nele,mmul),aka(nele,mmul)
1914 common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
1915 common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
1916 common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz), &
1917 &tilts(nblz),mout2,icext(nblz),icextal(nblz)
1918 common/beo /aper(2),di0(2),dip0(2),ta(6,6)
1919 common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
1920 &iout
1921 common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
1922 common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint, &
1923 &ntco,eui,euii,nlin,bezl(nele)
1924 common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2), &
1925 &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr, &
1926 &ncororb(nele)
1927 common/apert/apx(nele),apz(nele),ape(3,nele)
1928 common/clos/sigma0(2),iclo,ncorru,ncorrep
1929 common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20), &
1930 &ratioe(nele),iratioe(nele),icoe
1931 common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
1932 common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
1933 common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
1934 common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
1935 common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2, &
1936 &nstart,nstop,iskip,iconv,imad
1937 common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
1938 common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
1939 common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
1940 common/ripp2/nrturn
1941 common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
1942 common/pawc/hmal(nplo)
1943 common/tit/sixtit,commen,ithick
1944 common/co6d/clo6(3),clop6(3)
1945 common/dkic/dki(nele,3)
1946 common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb), &
1947 &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart), &
1948 &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar, &
1949 &nbeam,ibbc,ibeco,ibtyp,lhc
1950 common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
1951 common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
1952 common/wireco/ wirel(nele)
1953 common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele), &
1954 &nturn3(nele), nturn4(nele)
1955 integer idz,itra
1956 double precision al,as,chi0,chid,dp1,dps,exz,sigm
1957 common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa), &
1958 &dps(mpa),idz(2)
1959 common/anf/chi0,chid,exz(2,6),dp1,itra
1960 integer ichrom,is
1961 double precision alf0,amp,bet0,clo,clop,cro,x,y
1962 common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
1963 common/chrom/cro(2),is(2),ichrom
1964 integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
1965 &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
1966 double precision dpmax,preda,weig1,weig2
1967 character*16 coel
1968 common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
1969 common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
1970 common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
1971 &coel(10)
1972 double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
1973 &zsi
1974 real tlim,time0,time1
1975 common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz), &
1976 &aai(nblz,mmul),bbi(nblz,mmul)
1977 common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
1978 common/damp/damp,ampt
1979 common/ttime/tlim,time0,time1
1980 double precision tasm
1981 common/tasm/tasm(6,6)
1982 integer iv,ixv,nlostp,nms,numxv
1983 double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
1984 &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
1985 &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl, &
1986 &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
1987 &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv, &
1988 &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas, &
1989 &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
1990 &zsiv,zsv
1991 logical pstop
1992 common/main1/ &
1993 &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz), &
1994 &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz), &
1995 &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2), &
1996 &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart), &
1997 &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart), &
1998 &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart), &
1999 &xlv(npart),zlv(npart),pstop(npart),rvv(npart), &
2000 &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
2001 common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart), &
2002 &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart), &
2003 &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart), &
2004 &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart), &
2005 &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart), &
2006 &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
2007 &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
2008 &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart), &
2009 &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
2010 common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo), &
2011 &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart), &
2012 &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6), &
2013 &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
2014 integer numx
2015 double precision e0f
2016 common/main4/ e0f,numx
2017 integer ktrack,nwri
2018 double precision dpsv1,strack,strackc,stracks
2019 common/track/ ktrack(nblz),strack(nblz),strackc(nblz), &
2020 &stracks(nblz),dpsv1(npart),nwri
2021 double precision cc,xlim,ylim
2022 parameter(cc = 1.12837916709551d0)
2023 parameter(xlim = 5.33d0)
2024 parameter(ylim = 4.29d0)
2025 dimension crkveb(npart),cikveb(npart),rho2b(npart),tkb(npart), &
2026 &r2b(npart),rb(npart),rkb(npart), &
2027 &xrb(npart),zrb(npart),xbb(npart),zbb(npart),crxb(npart), &
2028 &crzb(npart),cbxb(npart),cbzb(npart)
2029 dimension dpsv3(npart)
2030 save
2031 !-----------------------------------------------------------------------
2032 nthinerr=0
2033 do 640 n=1,numl
2034 numx=n-1
2035 if(irip.eq.1) call ripple(n)
2036 if(mod(numx,nwri).eq.0) call writebin(nthinerr)
2037 if(nthinerr.ne.0) return
2038 do 630 i=1,iu
2039 ix=ic(i)-nblo
2040 !---------count:43
2041 goto(10,630,740,630,630,630,630,630,630,630,30,50,70,90,110, &
2042 &130,150,170,190,210,420,440,460,480,500,520,540,560,580,600, &
2043 &620,390,230,250,270,290,310,330,350,370,680,700,720,630,748, &
2044 &630,630,630,630,630,745,746),ktrack(i)
2045 goto 630
2046 10 stracki=strack(i)
2047 do 20 j=1,napx
2048 xv(1,j)=xv(1,j)+stracki*yv(1,j)
2049 xv(2,j)=xv(2,j)+stracki*yv(2,j)
2050 20 continue
2051 goto 630
2052 !--HORIZONTAL DIPOLE
2053 30 do 40 j=1,napx
2054 yv(1,j)=yv(1,j)+strackc(i)*oidpsv(j)
2055 yv(2,j)=yv(2,j)+stracks(i)*oidpsv(j)
2056 40 continue
2057 goto 620
2058 !--NORMAL QUADRUPOLE
2059 50 do 60 j=1,napx
2060 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
2061 &(xv(2,j)-zsiv(1,i))*tilts(i)
2062 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
2063 &(xv(2,j)-zsiv(1,i))*tiltc(i)
2064 crkve=xlv(j)
2065 cikve=zlv(j)
2066 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
2067 &stracks(i)*cikve)
2068 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
2069 &stracks(i)*crkve)
2070 60 continue
2071 goto 620
2072 !--NORMAL SEXTUPOLE
2073 70 do 80 j=1,napx
2074 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
2075 &(xv(2,j)-zsiv(1,i))*tilts(i)
2076 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
2077 &(xv(2,j)-zsiv(1,i))*tiltc(i)
2078 crkve=xlv(j)
2079 cikve=zlv(j)
2080 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2081 cikve=crkve*zlv(j)+cikve*xlv(j)
2082 crkve=crkveuk
2083 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
2084 &stracks(i)*cikve)
2085 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
2086 &stracks(i)*crkve)
2087 80 continue
2088 goto 620
2089 !--NORMAL OCTUPOLE
2090 90 do 100 j=1,napx
2091 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
2092 &(xv(2,j)-zsiv(1,i))*tilts(i)
2093 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
2094 &(xv(2,j)-zsiv(1,i))*tiltc(i)
2095 crkve=xlv(j)
2096 cikve=zlv(j)
2097 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2098 cikve=crkve*zlv(j)+cikve*xlv(j)
2099 crkve=crkveuk
2100 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2101 cikve=crkve*zlv(j)+cikve*xlv(j)
2102 crkve=crkveuk
2103 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
2104 &stracks(i)*cikve)
2105 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
2106 &stracks(i)*crkve)
2107 100 continue
2108 goto 620
2109 !--NORMAL DECAPOLE
2110 110 do 120 j=1,napx
2111 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
2112 &(xv(2,j)-zsiv(1,i))*tilts(i)
2113 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
2114 &(xv(2,j)-zsiv(1,i))*tiltc(i)
2115 crkve=xlv(j)
2116 cikve=zlv(j)
2117 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2118 cikve=crkve*zlv(j)+cikve*xlv(j)
2119 crkve=crkveuk
2120 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2121 cikve=crkve*zlv(j)+cikve*xlv(j)
2122 crkve=crkveuk
2123 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2124 cikve=crkve*zlv(j)+cikve*xlv(j)
2125 crkve=crkveuk
2126 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
2127 &stracks(i)*cikve)
2128 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
2129 &stracks(i)*crkve)
2130 120 continue
2131 goto 620
2132 !--NORMAL DODECAPOLE
2133 130 do 140 j=1,napx
2134 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
2135 &(xv(2,j)-zsiv(1,i))*tilts(i)
2136 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
2137 &(xv(2,j)-zsiv(1,i))*tiltc(i)
2138 crkve=xlv(j)
2139 cikve=zlv(j)
2140 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2141 cikve=crkve*zlv(j)+cikve*xlv(j)
2142 crkve=crkveuk
2143 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2144 cikve=crkve*zlv(j)+cikve*xlv(j)
2145 crkve=crkveuk
2146 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2147 cikve=crkve*zlv(j)+cikve*xlv(j)
2148 crkve=crkveuk
2149 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2150 cikve=crkve*zlv(j)+cikve*xlv(j)
2151 crkve=crkveuk
2152 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
2153 &stracks(i)*cikve)
2154 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
2155 &stracks(i)*crkve)
2156 140 continue
2157 goto 620
2158 !--NORMAL 14-POLE
2159 150 do 160 j=1,napx
2160 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
2161 &(xv(2,j)-zsiv(1,i))*tilts(i)
2162 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
2163 &(xv(2,j)-zsiv(1,i))*tiltc(i)
2164 crkve=xlv(j)
2165 cikve=zlv(j)
2166 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2167 cikve=crkve*zlv(j)+cikve*xlv(j)
2168 crkve=crkveuk
2169 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2170 cikve=crkve*zlv(j)+cikve*xlv(j)
2171 crkve=crkveuk
2172 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2173 cikve=crkve*zlv(j)+cikve*xlv(j)
2174 crkve=crkveuk
2175 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2176 cikve=crkve*zlv(j)+cikve*xlv(j)
2177 crkve=crkveuk
2178 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2179 cikve=crkve*zlv(j)+cikve*xlv(j)
2180 crkve=crkveuk
2181 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
2182 &stracks(i)*cikve)
2183 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
2184 &stracks(i)*crkve)
2185 160 continue
2186 goto 620
2187 !--NORMAL 16-POLE
2188 170 do 180 j=1,napx
2189 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
2190 &(xv(2,j)-zsiv(1,i))*tilts(i)
2191 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
2192 &(xv(2,j)-zsiv(1,i))*tiltc(i)
2193 crkve=xlv(j)
2194 cikve=zlv(j)
2195 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2196 cikve=crkve*zlv(j)+cikve*xlv(j)
2197 crkve=crkveuk
2198 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2199 cikve=crkve*zlv(j)+cikve*xlv(j)
2200 crkve=crkveuk
2201 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2202 cikve=crkve*zlv(j)+cikve*xlv(j)
2203 crkve=crkveuk
2204 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2205 cikve=crkve*zlv(j)+cikve*xlv(j)
2206 crkve=crkveuk
2207 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2208 cikve=crkve*zlv(j)+cikve*xlv(j)
2209 crkve=crkveuk
2210 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2211 cikve=crkve*zlv(j)+cikve*xlv(j)
2212 crkve=crkveuk
2213 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
2214 &stracks(i)*cikve)
2215 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
2216 &stracks(i)*crkve)
2217 180 continue
2218 goto 620
2219 !--NORMAL 18-POLE
2220 190 do 200 j=1,napx
2221 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
2222 &(xv(2,j)-zsiv(1,i))*tilts(i)
2223 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
2224 &(xv(2,j)-zsiv(1,i))*tiltc(i)
2225 crkve=xlv(j)
2226 cikve=zlv(j)
2227 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2228 cikve=crkve*zlv(j)+cikve*xlv(j)
2229 crkve=crkveuk
2230 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2231 cikve=crkve*zlv(j)+cikve*xlv(j)
2232 crkve=crkveuk
2233 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2234 cikve=crkve*zlv(j)+cikve*xlv(j)
2235 crkve=crkveuk
2236 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2237 cikve=crkve*zlv(j)+cikve*xlv(j)
2238 crkve=crkveuk
2239 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2240 cikve=crkve*zlv(j)+cikve*xlv(j)
2241 crkve=crkveuk
2242 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2243 cikve=crkve*zlv(j)+cikve*xlv(j)
2244 crkve=crkveuk
2245 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2246 cikve=crkve*zlv(j)+cikve*xlv(j)
2247 crkve=crkveuk
2248 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
2249 &stracks(i)*cikve)
2250 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
2251 &stracks(i)*crkve)
2252 200 continue
2253 goto 620
2254 !--NORMAL 20-POLE
2255 210 do 220 j=1,napx
2256 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
2257 &(xv(2,j)-zsiv(1,i))*tilts(i)
2258 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
2259 &(xv(2,j)-zsiv(1,i))*tiltc(i)
2260 crkve=xlv(j)
2261 cikve=zlv(j)
2262 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2263 cikve=crkve*zlv(j)+cikve*xlv(j)
2264 crkve=crkveuk
2265 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2266 cikve=crkve*zlv(j)+cikve*xlv(j)
2267 crkve=crkveuk
2268 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2269 cikve=crkve*zlv(j)+cikve*xlv(j)
2270 crkve=crkveuk
2271 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2272 cikve=crkve*zlv(j)+cikve*xlv(j)
2273 crkve=crkveuk
2274 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2275 cikve=crkve*zlv(j)+cikve*xlv(j)
2276 crkve=crkveuk
2277 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2278 cikve=crkve*zlv(j)+cikve*xlv(j)
2279 crkve=crkveuk
2280 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2281 cikve=crkve*zlv(j)+cikve*xlv(j)
2282 crkve=crkveuk
2283 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2284 cikve=crkve*zlv(j)+cikve*xlv(j)
2285 crkve=crkveuk
2286 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
2287 &stracks(i)*cikve)
2288 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
2289 &stracks(i)*crkve)
2290 220 continue
2291 goto 620
2292 230 continue
2293 do 240 j=1,napx
2294 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
2295 &(xv(2,j)-zsiv(1,i))*tilts(i)
2296 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
2297 &(xv(2,j)-zsiv(1,i))*tiltc(i)
2298 yv(1,j)=yv(1,j)-(strack(i)*xlvj*oidpsv(j) &
2299 &+dpsv1(j))*dki(ix,1)*tiltc(i) &
2300 &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
2301 yv(2,j)=yv(2,j)-(strack(i)*xlvj*oidpsv(j) &
2302 &+dpsv1(j))*dki(ix,1)*tilts(i) &
2303 &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
2304 240 continue
2305 goto 620
2306 250 continue
2307 do 260 j=1,napx
2308 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
2309 &(xv(2,j)-zsiv(1,i))*tilts(i)
2310 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
2311 &(xv(2,j)-zsiv(1,i))*tiltc(i)
2312 yv(1,j)=yv(1,j)-(strack(i)*xlvj*oidpsv(j) &
2313 &+dpsv1(j))*dki(ix,1)*tiltc(i) &
2314 &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
2315 yv(2,j)=yv(2,j)-(strack(i)*xlvj*oidpsv(j) &
2316 &+dpsv1(j))*dki(ix,1)*tilts(i) &
2317 &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
2318 260 continue
2319 goto 390
2320 270 continue
2321 do 280 j=1,napx
2322 yv(1,j)=yv(1,j)-strackc(i)*dpsv1(j) &
2323 &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
2324 yv(2,j)=yv(2,j)-stracks(i)*dpsv1(j) &
2325 &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
2326 280 continue
2327 goto 620
2328 290 continue
2329 do 300 j=1,napx
2330 yv(1,j)=yv(1,j)-strackc(i)*dpsv1(j) &
2331 &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
2332 yv(2,j)=yv(2,j)-stracks(i)*dpsv1(j) &
2333 &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
2334 300 continue
2335 goto 390
2336 310 continue
2337 do 320 j=1,napx
2338 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
2339 &(xv(2,j)-zsiv(1,i))*tilts(i)
2340 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
2341 &(xv(2,j)-zsiv(1,i))*tiltc(i)
2342 yv(1,j)=yv(1,j)+(strack(i)*zlvj*oidpsv(j) &
2343 &-dpsv1(j))*dki(ix,2)*tilts(i) &
2344 &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
2345 yv(2,j)=yv(2,j)-(strack(i)*zlvj*oidpsv(j) &
2346 &-dpsv1(j))*dki(ix,2)*tiltc(i) &
2347 &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
2348 320 continue
2349 goto 620
2350 330 continue
2351 do 340 j=1,napx
2352 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
2353 &(xv(2,j)-zsiv(1,i))*tilts(i)
2354 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
2355 &(xv(2,j)-zsiv(1,i))*tiltc(i)
2356 yv(1,j)=yv(1,j)+(strack(i)*zlvj*oidpsv(j) &
2357 &-dpsv1(j))*dki(ix,2)*tilts(i) &
2358 &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
2359 yv(2,j)=yv(2,j)-(strack(i)*zlvj*oidpsv(j) &
2360 &-dpsv1(j))*dki(ix,2)*tiltc(i) &
2361 &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
2362 340 continue
2363 goto 390
2364 350 continue
2365 do 360 j=1,napx
2366 yv(1,j)=yv(1,j)-stracks(i)*dpsv1(j) &
2367 &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
2368 yv(2,j)=yv(2,j)+strackc(i)*dpsv1(j) &
2369 &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
2370 360 continue
2371 goto 620
2372 370 continue
2373 do 380 j=1,napx
2374 yv(1,j)=yv(1,j)-stracks(i)*dpsv1(j) &
2375 &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
2376 yv(2,j)=yv(2,j)+strackc(i)*dpsv1(j) &
2377 &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
2378 380 continue
2379 390 r0=ek(ix)
2380 nmz=nmu(ix)
2381 if(nmz.ge.2) then
2382 do 410 j=1,napx
2383 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
2384 &(xv(2,j)-zsiv(1,i))*tilts(i)
2385 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
2386 &(xv(2,j)-zsiv(1,i))*tiltc(i)
2387 yv1j=bbiv(1,1,i)+bbiv(2,1,i)*xlvj+aaiv(2,1,i)*zlvj
2388 yv2j=aaiv(1,1,i)-bbiv(2,1,i)*zlvj+aaiv(2,1,i)*xlvj
2389 crkve=xlvj
2390 cikve=zlvj
2391 do 400 k=3,nmz
2392 crkveuk=crkve*xlvj-cikve*zlvj
2393 cikve=crkve*zlvj+cikve*xlvj
2394 crkve=crkveuk
2395 yv1j=yv1j+bbiv(k,1,i)*crkve+aaiv(k,1,i)*cikve
2396 yv2j=yv2j-bbiv(k,1,i)*cikve+aaiv(k,1,i)*crkve
2397 400 continue
2398 yv(1,j)=yv(1,j)+(tiltc(i)*yv1j-tilts(i)*yv2j)*oidpsv(j)
2399 yv(2,j)=yv(2,j)+(tiltc(i)*yv2j+tilts(i)*yv1j)*oidpsv(j)
2400 410 continue
2401 else
2402 do 415 j=1,napx
2403 yv(1,j)=yv(1,j)+(tiltc(i)*bbiv(1,1,i)- &
2404 &tilts(i)*aaiv(1,1,i))*oidpsv(j)
2405 yv(2,j)=yv(2,j)+(tiltc(i)*aaiv(1,1,i)+ &
2406 &tilts(i)*bbiv(1,1,i))*oidpsv(j)
2407 415 continue
2408 endif
2409 goto 620
2410 !--SKEW ELEMENTS
2411 !--VERTICAL DIPOLE
2412 420 do 430 j=1,napx
2413 yv(1,j)=yv(1,j)-stracks(i)*oidpsv(j)
2414 yv(2,j)=yv(2,j)+strackc(i)*oidpsv(j)
2415 430 continue
2416 goto 620
2417 !--SKEW QUADRUPOLE
2418 440 do 450 j=1,napx
2419 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
2420 &(xv(2,j)-zsiv(1,i))*tilts(i)
2421 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
2422 &(xv(2,j)-zsiv(1,i))*tiltc(i)
2423 crkve=xlv(j)
2424 cikve=zlv(j)
2425 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
2426 &stracks(i)*crkve)
2427 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
2428 &stracks(i)*cikve)
2429 450 continue
2430 goto 620
2431 !--SKEW SEXTUPOLE
2432 460 do 470 j=1,napx
2433 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
2434 &(xv(2,j)-zsiv(1,i))*tilts(i)
2435 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
2436 &(xv(2,j)-zsiv(1,i))*tiltc(i)
2437 crkve=xlv(j)
2438 cikve=zlv(j)
2439 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2440 cikve=crkve*zlv(j)+cikve*xlv(j)
2441 crkve=crkveuk
2442 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
2443 &stracks(i)*crkve)
2444 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
2445 &stracks(i)*cikve)
2446 470 continue
2447 goto 620
2448 !--SKEW OCTUPOLE
2449 480 do 490 j=1,napx
2450 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
2451 &(xv(2,j)-zsiv(1,i))*tilts(i)
2452 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
2453 &(xv(2,j)-zsiv(1,i))*tiltc(i)
2454 crkve=xlv(j)
2455 cikve=zlv(j)
2456 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2457 cikve=crkve*zlv(j)+cikve*xlv(j)
2458 crkve=crkveuk
2459 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2460 cikve=crkve*zlv(j)+cikve*xlv(j)
2461 crkve=crkveuk
2462 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
2463 &stracks(i)*crkve)
2464 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
2465 &stracks(i)*cikve)
2466 490 continue
2467 goto 620
2468 !--SKEW DECAPOLE
2469 500 do 510 j=1,napx
2470 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
2471 &(xv(2,j)-zsiv(1,i))*tilts(i)
2472 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
2473 &(xv(2,j)-zsiv(1,i))*tiltc(i)
2474 crkve=xlv(j)
2475 cikve=zlv(j)
2476 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2477 cikve=crkve*zlv(j)+cikve*xlv(j)
2478 crkve=crkveuk
2479 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2480 cikve=crkve*zlv(j)+cikve*xlv(j)
2481 crkve=crkveuk
2482 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2483 cikve=crkve*zlv(j)+cikve*xlv(j)
2484 crkve=crkveuk
2485 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
2486 &stracks(i)*crkve)
2487 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
2488 &stracks(i)*cikve)
2489 510 continue
2490 goto 620
2491 !--SKEW DODECAPOLE
2492 520 do 530 j=1,napx
2493 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
2494 &(xv(2,j)-zsiv(1,i))*tilts(i)
2495 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
2496 &(xv(2,j)-zsiv(1,i))*tiltc(i)
2497 crkve=xlv(j)
2498 cikve=zlv(j)
2499 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2500 cikve=crkve*zlv(j)+cikve*xlv(j)
2501 crkve=crkveuk
2502 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2503 cikve=crkve*zlv(j)+cikve*xlv(j)
2504 crkve=crkveuk
2505 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2506 cikve=crkve*zlv(j)+cikve*xlv(j)
2507 crkve=crkveuk
2508 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2509 cikve=crkve*zlv(j)+cikve*xlv(j)
2510 crkve=crkveuk
2511 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
2512 &stracks(i)*crkve)
2513 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
2514 &stracks(i)*cikve)
2515 530 continue
2516 goto 620
2517 !--SKEW 14-POLE
2518 540 do 550 j=1,napx
2519 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
2520 &(xv(2,j)-zsiv(1,i))*tilts(i)
2521 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
2522 &(xv(2,j)-zsiv(1,i))*tiltc(i)
2523 crkve=xlv(j)
2524 cikve=zlv(j)
2525 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2526 cikve=crkve*zlv(j)+cikve*xlv(j)
2527 crkve=crkveuk
2528 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2529 cikve=crkve*zlv(j)+cikve*xlv(j)
2530 crkve=crkveuk
2531 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2532 cikve=crkve*zlv(j)+cikve*xlv(j)
2533 crkve=crkveuk
2534 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2535 cikve=crkve*zlv(j)+cikve*xlv(j)
2536 crkve=crkveuk
2537 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2538 cikve=crkve*zlv(j)+cikve*xlv(j)
2539 crkve=crkveuk
2540 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
2541 &stracks(i)*crkve)
2542 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
2543 &stracks(i)*cikve)
2544 550 continue
2545 goto 620
2546 !--SKEW 16-POLE
2547 560 do 570 j=1,napx
2548 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
2549 &(xv(2,j)-zsiv(1,i))*tilts(i)
2550 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
2551 &(xv(2,j)-zsiv(1,i))*tiltc(i)
2552 crkve=xlv(j)
2553 cikve=zlv(j)
2554 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2555 cikve=crkve*zlv(j)+cikve*xlv(j)
2556 crkve=crkveuk
2557 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2558 cikve=crkve*zlv(j)+cikve*xlv(j)
2559 crkve=crkveuk
2560 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2561 cikve=crkve*zlv(j)+cikve*xlv(j)
2562 crkve=crkveuk
2563 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2564 cikve=crkve*zlv(j)+cikve*xlv(j)
2565 crkve=crkveuk
2566 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2567 cikve=crkve*zlv(j)+cikve*xlv(j)
2568 crkve=crkveuk
2569 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2570 cikve=crkve*zlv(j)+cikve*xlv(j)
2571 crkve=crkveuk
2572 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
2573 &stracks(i)*crkve)
2574 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
2575 &stracks(i)*cikve)
2576 570 continue
2577 goto 620
2578 !--SKEW 18-POLE
2579 580 do 590 j=1,napx
2580 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
2581 &(xv(2,j)-zsiv(1,i))*tilts(i)
2582 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
2583 &(xv(2,j)-zsiv(1,i))*tiltc(i)
2584 crkve=xlv(j)
2585 cikve=zlv(j)
2586 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2587 cikve=crkve*zlv(j)+cikve*xlv(j)
2588 crkve=crkveuk
2589 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2590 cikve=crkve*zlv(j)+cikve*xlv(j)
2591 crkve=crkveuk
2592 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2593 cikve=crkve*zlv(j)+cikve*xlv(j)
2594 crkve=crkveuk
2595 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2596 cikve=crkve*zlv(j)+cikve*xlv(j)
2597 crkve=crkveuk
2598 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2599 cikve=crkve*zlv(j)+cikve*xlv(j)
2600 crkve=crkveuk
2601 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2602 cikve=crkve*zlv(j)+cikve*xlv(j)
2603 crkve=crkveuk
2604 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2605 cikve=crkve*zlv(j)+cikve*xlv(j)
2606 crkve=crkveuk
2607 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
2608 &stracks(i)*crkve)
2609 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
2610 &stracks(i)*cikve)
2611 590 continue
2612 goto 620
2613 !--SKEW 20-POLE
2614 600 do 610 j=1,napx
2615 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
2616 &(xv(2,j)-zsiv(1,i))*tilts(i)
2617 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
2618 &(xv(2,j)-zsiv(1,i))*tiltc(i)
2619 crkve=xlv(j)
2620 cikve=zlv(j)
2621 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2622 cikve=crkve*zlv(j)+cikve*xlv(j)
2623 crkve=crkveuk
2624 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2625 cikve=crkve*zlv(j)+cikve*xlv(j)
2626 crkve=crkveuk
2627 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2628 cikve=crkve*zlv(j)+cikve*xlv(j)
2629 crkve=crkveuk
2630 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2631 cikve=crkve*zlv(j)+cikve*xlv(j)
2632 crkve=crkveuk
2633 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2634 cikve=crkve*zlv(j)+cikve*xlv(j)
2635 crkve=crkveuk
2636 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2637 cikve=crkve*zlv(j)+cikve*xlv(j)
2638 crkve=crkveuk
2639 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2640 cikve=crkve*zlv(j)+cikve*xlv(j)
2641 crkve=crkveuk
2642 crkveuk=crkve*xlv(j)-cikve*zlv(j)
2643 cikve=crkve*zlv(j)+cikve*xlv(j)
2644 crkve=crkveuk
2645 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
2646 &stracks(i)*crkve)
2647 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
2648 &stracks(i)*cikve)
2649 610 continue
2650 goto 620
2651 680 continue
2652 do 690 j=1,napx
2653 if(ibbc.eq.0) then
2654 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
2655 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
2656 else
2657 crkveb(j)= &
2658 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
2659 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
2660 cikveb(j)= &
2661 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
2662 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
2663 endif
2664 rho2b(j)=crkveb(j)*crkveb(j)+cikveb(j)*cikveb(j)
2665 if(rho2b(j).le.pieni) &
2666 &goto 690
2667 tkb(j)=rho2b(j)/(two*sigman2(1,imbb(i)))
2668 if(ibbc.eq.0) then
2669 yv(1,j)=yv(1,j)+oidpsv(j)*(strack(i)*crkveb(j)/rho2b(j)* &
2670 &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))
2671 yv(2,j)=yv(2,j)+oidpsv(j)*(strack(i)*cikveb(j)/rho2b(j)* &
2672 &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))
2673 else
2674 cccc=(strack(i)*crkveb(j)/rho2b(j)* &
2675 &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))*bbcu(imbb(i),11)- &
2676 &(strack(i)*cikveb(j)/rho2b(j)* &
2677 &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
2678 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
2679 cccc=(strack(i)*crkveb(j)/rho2b(j)* &
2680 &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))*bbcu(imbb(i),12)+ &
2681 &(strack(i)*cikveb(j)/rho2b(j)* &
2682 &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
2683 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
2684 endif
2685 690 continue
2686 goto 620
2687 700 continue
2688 if(ibtyp.eq.0) then
2689 do j=1,napx
2690 r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
2691 rb(j)=sqrt(r2b(j))
2692 rkb(j)=strack(i)*pisqrt/rb(j)
2693 if(ibbc.eq.0) then
2694 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
2695 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
2696 else
2697 crkveb(j)= &
2698 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
2699 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
2700 cikveb(j)= &
2701 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
2702 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
2703 endif
2704 xrb(j)=abs(crkveb(j))/rb(j)
2705 zrb(j)=abs(cikveb(j))/rb(j)
2706 call errf(xrb(j),zrb(j),crxb(j),crzb(j))
2707 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
2708 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
2709 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
2710 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
2711 call errf(xbb(j),zbb(j),cbxb(j),cbzb(j))
2712 if(ibbc.eq.0) then
2713 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
2714 &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
2715 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
2716 &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
2717 else
2718 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
2719 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
2720 &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
2721 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
2722 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
2723 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
2724 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
2725 &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
2726 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
2727 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
2728 endif
2729 enddo
2730 else if(ibtyp.eq.1) then
2731 do j=1,napx
2732 r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
2733 rb(j)=sqrt(r2b(j))
2734 rkb(j)=strack(i)*pisqrt/rb(j)
2735 if(ibbc.eq.0) then
2736 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
2737 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
2738 else
2739 crkveb(j)= &
2740 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
2741 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
2742 cikveb(j)= &
2743 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
2744 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
2745 endif
2746 xrb(j)=abs(crkveb(j))/rb(j)
2747 zrb(j)=abs(cikveb(j))/rb(j)
2748 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
2749 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
2750 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
2751 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
2752 enddo
2753 call wzsubv(napx,xrb(1),zrb(1),crxb(1),crzb(1))
2754 call wzsubv(napx,xbb(1),zbb(1),cbxb(1),cbzb(1))
2755 do j=1,napx
2756 if(ibbc.eq.0) then
2757 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
2758 &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
2759 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
2760 &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
2761 else
2762 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
2763 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
2764 &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
2765 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
2766 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
2767 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
2768 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
2769 &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
2770 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
2771 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
2772 endif
2773 enddo
2774 endif
2775 goto 620
2776 720 continue
2777 if(ibtyp.eq.0) then
2778 do j=1,napx
2779 r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
2780 rb(j)=sqrt(r2b(j))
2781 rkb(j)=strack(i)*pisqrt/rb(j)
2782 if(ibbc.eq.0) then
2783 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
2784 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
2785 else
2786 crkveb(j)= &
2787 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
2788 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
2789 cikveb(j)= &
2790 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
2791 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
2792 endif
2793 xrb(j)=abs(crkveb(j))/rb(j)
2794 zrb(j)=abs(cikveb(j))/rb(j)
2795 call errf(zrb(j),xrb(j),crzb(j),crxb(j))
2796 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
2797 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
2798 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
2799 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
2800 call errf(zbb(j),xbb(j),cbzb(j),cbxb(j))
2801 if(ibbc.eq.0) then
2802 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
2803 &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
2804 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
2805 &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
2806 else
2807 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
2808 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
2809 &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
2810 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
2811 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
2812 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
2813 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
2814 &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
2815 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
2816 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
2817 endif
2818 enddo
2819 else if(ibtyp.eq.1) then
2820 do j=1,napx
2821 r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
2822 rb(j)=sqrt(r2b(j))
2823 rkb(j)=strack(i)*pisqrt/rb(j)
2824 if(ibbc.eq.0) then
2825 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
2826 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
2827 else
2828 crkveb(j)= &
2829 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
2830 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
2831 cikveb(j)= &
2832 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
2833 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
2834 endif
2835 xrb(j)=abs(crkveb(j))/rb(j)
2836 zrb(j)=abs(cikveb(j))/rb(j)
2837 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
2838 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
2839 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
2840 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
2841 enddo
2842 call wzsubv(napx,zrb(1),xrb(1),crzb(1),crxb(1))
2843 call wzsubv(napx,zbb(1),xbb(1),cbzb(1),cbxb(1))
2844 do j=1,napx
2845 if(ibbc.eq.0) then
2846 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
2847 &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
2848 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
2849 &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
2850 else
2851 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
2852 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
2853 &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
2854 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
2855 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
2856 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
2857 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
2858 &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
2859 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
2860 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
2861 endif
2862 enddo
2863 endif
2864 goto 620
2865 740 continue
2866 irrtr=imtr(ix)
2867 do j=1,napx
2868 pux=xv(1,j)
2869 dpsv3(j)=dpsv(j)*c1e3
2870 xv(1,j)=cotr(irrtr,1)+rrtr(irrtr,1,1)*pux+ &
2871 &rrtr(irrtr,1,2)*yv(1,j)+idz(1)*dpsv3(j)*rrtr(irrtr,1,6)
2872 yv(1,j)=cotr(irrtr,2)+rrtr(irrtr,2,1)*pux+ &
2873 &rrtr(irrtr,2,2)*yv(1,j)+idz(1)*dpsv3(j)*rrtr(irrtr,2,6)
2874 pux=xv(2,j)
2875 xv(2,j)=cotr(irrtr,3)+rrtr(irrtr,3,3)*pux+ &
2876 &rrtr(irrtr,3,4)*yv(2,j)+idz(2)*dpsv3(j)*rrtr(irrtr,3,6)
2877 yv(2,j)=cotr(irrtr,4)+rrtr(irrtr,4,3)*pux+ &
2878 &rrtr(irrtr,4,4)*yv(2,j)+idz(2)*dpsv3(j)*rrtr(irrtr,4,6)
2879 enddo
2880
2881 !----------------------------------------------------------------------
2882
2883 ! Wire.
2884
2885 goto 620
2886 745 continue
2887 xory=1
2888 nfree=nturn1(ix)
2889 if(n.gt.nfree) then
2890 nac=n-nfree
2891 pi=4d0*atan(1d0)
2892 !---------ACdipAmp input in Tesla*meter converted to KeV/c
2893 !---------ejfv(j) should be in MeV/c --> ACdipAmp/ejfv(j) is in mrad
2894 acdipamp=ed(ix)*clight*1.0d-3
2895 !---------Qd input in tune units
2896 qd=ek(ix)
2897 !---------ACphase input in radians
2898 acphase=acdipph(ix)
2899 nramp1=nturn2(ix)
2900 nplato=nturn3(ix)
2901 nramp2=nturn4(ix)
2902 do j=1,napx
2903 if (xory.eq.1) then
2904 acdipamp2=acdipamp*tilts(i)
2905 acdipamp1=acdipamp*tiltc(i)
2906 else
2907 acdipamp2=acdipamp*tiltc(i)
2908 acdipamp1=-acdipamp*tilts(i)
2909 endif
2910 if(nramp1.gt.nac) then
2911 yv(1,j)=yv(1,j)+acdipamp1* &
2912 &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
2913 yv(2,j)=yv(2,j)+acdipamp2* &
2914 &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
2915 endif
2916 if(nac.ge.nramp1.and.(nramp1+nplato).gt.nac) then
2917 yv(1,j)=yv(1,j)+acdipamp1* &
2918 &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
2919 yv(2,j)=yv(2,j)+acdipamp2* &
2920 &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
2921 endif
2922 if(nac.ge.(nramp1+nplato).and.(nramp2+nramp1+nplato).gt. &
2923 &nac)then
2924 yv(1,j)=yv(1,j)+acdipamp1*sin(2d0*pi*qd*nac+acphase)* &
2925 &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
2926 yv(2,j)=yv(2,j)+acdipamp2*sin(2d0*pi*qd*nac+acphase)* &
2927 &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
2928 endif
2929 enddo
2930 endif
2931 goto 620
2932 746 continue
2933 xory=2
2934 nfree=nturn1(ix)
2935 if(n.gt.nfree) then
2936 nac=n-nfree
2937 pi=4d0*atan(1d0)
2938 !---------ACdipAmp input in Tesla*meter converted to KeV/c
2939 !---------ejfv(j) should be in MeV/c --> ACdipAmp/ejfv(j) is in mrad
2940 acdipamp=ed(ix)*clight*1.0d-3
2941 !---------Qd input in tune units
2942 qd=ek(ix)
2943 !---------ACphase input in radians
2944 acphase=acdipph(ix)
2945 nramp1=nturn2(ix)
2946 nplato=nturn3(ix)
2947 nramp2=nturn4(ix)
2948 do j=1,napx
2949 if (xory.eq.1) then
2950 acdipamp2=acdipamp*tilts(i)
2951 acdipamp1=acdipamp*tiltc(i)
2952 else
2953 acdipamp2=acdipamp*tiltc(i)
2954 acdipamp1=-acdipamp*tilts(i)
2955 endif
2956 if(nramp1.gt.nac) then
2957 yv(1,j)=yv(1,j)+acdipamp1* &
2958 &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
2959 yv(2,j)=yv(2,j)+acdipamp2* &
2960 &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
2961 endif
2962 if(nac.ge.nramp1.and.(nramp1+nplato).gt.nac) then
2963 yv(1,j)=yv(1,j)+acdipamp1* &
2964 &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
2965 yv(2,j)=yv(2,j)+acdipamp2* &
2966 &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
2967 endif
2968 if(nac.ge.(nramp1+nplato).and.(nramp2+nramp1+nplato).gt. &
2969 &nac)then
2970 yv(1,j)=yv(1,j)+acdipamp1*sin(2d0*pi*qd*nac+acphase)* &
2971 &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
2972 yv(2,j)=yv(2,j)+acdipamp2*sin(2d0*pi*qd*nac+acphase)* &
2973 &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
2974 endif
2975 enddo
2976 endif
2977 goto 620
2978
2979 !----------------------------
2980
2981 ! Wire.
2982
2983 748 continue
2984 ! magnetic rigidity
2985 chi = sqrt(e0*e0-pmap*pmap)*c1e6/clight
2986
2987 ix = ixcav
2988 tx = xrms(ix)
2989 ty = zrms(ix)
2990 dx = xpl(ix)
2991 dy = zpl(ix)
2992 embl = ek(ix)
2993 l = wirel(ix)
2994 cur = ed(ix)
2995
2996 leff = embl/cos(tx)/cos(ty)
2997 rx = dx *cos(tx)-embl*sin(tx)/2
2998 lin= dx *sin(tx)+embl*cos(tx)/2
2999 ry = dy *cos(ty)-lin *sin(ty)
3000 lin= lin*cos(ty)+dy *sin(ty)
3001
3002 do 750 j=1, napx
3003
3004 xv(1,j) = xv(1,j) * c1m3
3005 xv(2,j) = xv(2,j) * c1m3
3006 yv(1,j) = yv(1,j) * c1m3
3007 yv(2,j) = yv(2,j) * c1m3
3008
3009 ! print *, 'Start: ',j,xv(1,j),xv(2,j),yv(1,j),
3010 ! &yv(2,j)
3011
3012 ! call drift(-embl/2)
3013
3014 xv(1,j) = xv(1,j) - embl/2*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
3015 &yv(2,j)**2)
3016 xv(2,j) = xv(2,j) - embl/2*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
3017 &yv(2,j)**2)
3018
3019 ! call tilt(tx,ty)
3020
3021 xv(2,j) = xv(2,j)-xv(1,j)*sin(tx)*yv(2,j)/sqrt((1+dpsv(j))**2- &
3022 &yv(2,j)**2)/cos(atan(yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
3023 &yv(2,j)**2))-tx)
3024 xv(1,j) = xv(1,j)*(cos(tx)-sin(tx)*tan(atan(yv(1,j)/ &
3025 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-tx))
3026 yv(1,j) = sqrt((1+dpsv(j))**2-yv(2,j)**2)*sin(atan(yv(1,j)/ &
3027 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-tx)
3028
3029 xv(1,j) = xv(1,j)-xv(2,j)*sin(ty)*yv(1,j)/sqrt((1+dpsv(j))**2- &
3030 &yv(1,j)**2)/cos(atan(yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
3031 &yv(2,j)**2))-ty)
3032 xv(2,j) = xv(2,j)*(cos(ty)-sin(ty)*tan(atan(yv(2,j)/ &
3033 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-ty))
3034 yv(2,j) = sqrt((1+dpsv(j))**2-yv(1,j)**2)*sin(atan(yv(2,j)/ &
3035 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-ty)
3036
3037 ! call drift(lin)
3038
3039 xv(1,j) = xv(1,j) + lin*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
3040 &yv(2,j)**2)
3041 xv(2,j) = xv(2,j) + lin*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
3042 &yv(2,j)**2)
3043
3044 ! call kick(l,cur,lin,rx,ry,chi)
3045
3046 xi = xv(1,j)-rx
3047 yi = xv(2,j)-ry
3048 yv(1,j) = yv(1,j)-1.0d-7*cur/chi*xi/(xi**2+yi**2)* &
3049 &(sqrt((lin+l)**2+xi**2+yi**2)-sqrt((lin-l)**2+ &
3050 &xi**2+yi**2))
3051 !GRD FOR CONSISTENSY
3052 ! yv(2,j) = yv(2,j)-1e-7*cur/chi*yi/(xi**2+yi**2)* &
3053 yv(2,j) = yv(2,j)-1.0d-7*cur/chi*yi/(xi**2+yi**2)* &
3054 &(sqrt((lin+l)**2+xi**2+yi**2)-sqrt((lin-l)**2+ &
3055 &xi**2+yi**2))
3056
3057 ! call drift(leff-lin)
3058
3059 xv(1,j) = xv(1,j) + (leff-lin)*yv(1,j)/sqrt((1+dpsv(j))**2- &
3060 &yv(1,j)**2-yv(2,j)**2)
3061 xv(2,j) = xv(2,j) + (leff-lin)*yv(2,j)/sqrt((1+dpsv(j))**2- &
3062 &yv(1,j)**2-yv(2,j)**2)
3063
3064 ! call invtilt(tx,ty)
3065
3066 xv(1,j) = xv(1,j)-xv(2,j)*sin(-ty)*yv(1,j)/sqrt((1+dpsv(j))**2- &
3067 &yv(1,j)**2)/cos(atan(yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
3068 &yv(2,j)**2))+ty)
3069 xv(2,j) = xv(2,j)*(cos(-ty)-sin(-ty)*tan(atan(yv(2,j)/ &
3070 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+ty))
3071 yv(2,j) = sqrt((1+dpsv(j))**2-yv(1,j)**2)*sin(atan(yv(2,j)/ &
3072 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+ty)
3073
3074 xv(2,j) = xv(2,j)-xv(1,j)*sin(-tx)*yv(2,j)/sqrt((1+dpsv(j))**2- &
3075 &yv(2,j)**2)/cos(atan(yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
3076 &yv(2,j)**2))+tx)
3077 xv(1,j) = xv(1,j)*(cos(-tx)-sin(-tx)*tan(atan(yv(1,j)/ &
3078 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+tx))
3079 yv(1,j) = sqrt((1+dpsv(j))**2-yv(2,j)**2)*sin(atan(yv(1,j)/ &
3080 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+tx)
3081
3082 ! call shift(-embl*tan(tx),-embl*tan(ty)/cos(tx))
3083
3084 xv(1,j) = xv(1,j) + embl*tan(tx)
3085 xv(2,j) = xv(2,j) + embl*tan(ty)/cos(tx)
3086
3087 ! call drift(-embl/2)
3088
3089 xv(1,j) = xv(1,j) - embl/2*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
3090 &yv(2,j)**2)
3091 xv(2,j) = xv(2,j) - embl/2*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
3092 &yv(2,j)**2)
3093
3094 xv(1,j) = xv(1,j) * c1e3
3095 xv(2,j) = xv(2,j) * c1e3
3096 yv(1,j) = yv(1,j) * c1e3
3097 yv(2,j) = yv(2,j) * c1e3
3098
3099 ! print *, 'End: ',j,xv(1,j),xv(2,j),yv(1,j),
3100 ! &yv(2,j)
3101
3102 !-----------------------------------------------------------------------
3103
3104 750 continue
3105 goto 620
3106
3107 !----------------------------
3108
3109 620 continue
3110 llost=.false.
3111 do j=1,napx
3112 llost=llost.or. &
3113 &abs(xv(1,j)).gt.aper(1).or.abs(xv(2,j)).gt.aper(2)
3114 enddo
3115 if (llost) then
3116 kpz=abs(kp(ix))
3117 if(kpz.eq.2) then
3118 call lostpar3(i,ix,nthinerr)
3119 if(nthinerr.ne.0) return
3120 elseif(kpz.eq.3) then
3121 call lostpar4(i,ix,nthinerr)
3122 if(nthinerr.ne.0) return
3123 else
3124 call lostpar2(i,ix,nthinerr)
3125 if(nthinerr.ne.0) return
3126 endif
3127 endif
3128 630 continue
3129 call lostpart(nthinerr)
3130 if(nthinerr.ne.0) return
3131 if(ntwin.ne.2) call dist1
3132 if(mod(n,nwr(4)).eq.0) call write6(n)
3133 640 continue
3134 return
3135 end
3136 subroutine thin6d(nthinerr)
3137 !-----------------------------------------------------------------------
3138 !
3139 ! TRACK THIN LENS 6D
3140 !
3141 !
3142 ! F. SCHMIDT
3143 !-----------------------------------------------------------------------
3144 implicit none
3145 integer i,irrtr,ix,j,k,kpz,n,nmz,nthinerr
3146 double precision c5m4,cbxb,cbzb,cccc,cikve,cikveb,crkve,crkveb, &
3147 &crkveuk,crxb,crzb,dpsv3,pux,r0,r2b,rb,rho2b,rkb,stracki,tkb,xbb, &
3148 &xlvj,xrb,yv1j,yv2j,zbb,zlvj,zrb
3149 integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1, &
3150 &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran, &
3151 &nrco,ntr,nzfz
3152 parameter(npart = 64,nmac = 1)
3153 parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000, &
3154 &nzfz = 300000,mmul = 11)
3155 parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5, &
3156 &nema = 15)
3157 parameter(mcor = 10,mcop = mcor+6, mbea = 15)
3158 parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
3159 parameter(nmon1 = 600,ncor1 = 600)
3160 parameter(ntr = 20,nbb = 160)
3161 integer ireturn, xory, nac, nfree, nramp1,nplato, nramp2
3162 double precision e0fo,e0o,xv1j,xv2j
3163 double precision acdipamp, qd, acphase,acdipamp2,acdipamp1
3164 double precision l,cur,dx,dy,tx,ty,embl,leff,rx,ry,lin,chi,xi,yi
3165 logical llost
3166 double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3, &
3167 &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21, &
3168 &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
3169 &one,pieni,pmae,pmap,three,two,zero
3170 parameter(pieni = 1d-38)
3171 parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
3172 parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
3173 parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
3174 parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
3175 parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 = &
3176 &1.0d16)
3177 parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
3178 parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
3179 parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
3180 parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
3181 parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
3182 parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
3183 parameter(pmap = 938.271998d0,pmae = .510998902d0)
3184 parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
3185 integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo, &
3186 &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor, &
3187 &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb, &
3188 &imc,imtr,iorg,iout, &
3189 &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires, &
3190 &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw, &
3191 &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox, &
3192 &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo, &
3193 &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx, &
3194 &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr, &
3195 &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew, &
3196 &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr, &
3197 &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
3198 double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu, &
3199 &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
3200 &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft, &
3201 &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
3202 &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign, &
3203 &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum, &
3204 &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
3205 &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph, &
3206 &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
3207 &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel, &
3208 &acdipph
3209 real hmal
3210 character*16 bez,bezb,bezr,erbez,bezl
3211 character*80 toptit,sixtit,commen
3212 common/erro/ierro,erbez
3213 common/kons/pi,pi2,pisqrt,rad
3214 common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
3215 common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
3216 common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
3217 common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
3218 common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
3219 common/syos2/rvf(mpa)
3220 common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
3221 &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
3222 common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3), &
3223 &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen, &
3224 &iicav,itionc(nele),ition,idp,ncy,ixcav
3225 common/corcom/dpscor,sigcor,icode,idam,its6d
3226 common/multi/bk0(nele,mmul),ak0(nele,mmul), &
3227 &bka(nele,mmul),aka(nele,mmul)
3228 common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
3229 common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
3230 common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz), &
3231 &tilts(nblz),mout2,icext(nblz),icextal(nblz)
3232 common/beo /aper(2),di0(2),dip0(2),ta(6,6)
3233 common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
3234 &iout
3235 common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
3236 common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint, &
3237 &ntco,eui,euii,nlin,bezl(nele)
3238 common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2), &
3239 &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr, &
3240 &ncororb(nele)
3241 common/apert/apx(nele),apz(nele),ape(3,nele)
3242 common/clos/sigma0(2),iclo,ncorru,ncorrep
3243 common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20), &
3244 &ratioe(nele),iratioe(nele),icoe
3245 common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
3246 common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
3247 common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
3248 common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
3249 common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2, &
3250 &nstart,nstop,iskip,iconv,imad
3251 common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
3252 common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
3253 common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
3254 common/ripp2/nrturn
3255 common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
3256 common/pawc/hmal(nplo)
3257 common/tit/sixtit,commen,ithick
3258 common/co6d/clo6(3),clop6(3)
3259 common/dkic/dki(nele,3)
3260 common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb), &
3261 &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart), &
3262 &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar, &
3263 &nbeam,ibbc,ibeco,ibtyp,lhc
3264 common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
3265 common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
3266 common/wireco/ wirel(nele)
3267 common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele), &
3268 &nturn3(nele), nturn4(nele)
3269 integer idz,itra
3270 double precision al,as,chi0,chid,dp1,dps,exz,sigm
3271 common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa), &
3272 &dps(mpa),idz(2)
3273 common/anf/chi0,chid,exz(2,6),dp1,itra
3274 integer ichrom,is
3275 double precision alf0,amp,bet0,clo,clop,cro,x,y
3276 common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
3277 common/chrom/cro(2),is(2),ichrom
3278 integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
3279 &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
3280 double precision dpmax,preda,weig1,weig2
3281 character*16 coel
3282 common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
3283 common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
3284 common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
3285 &coel(10)
3286 double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
3287 &zsi
3288 real tlim,time0,time1
3289 common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz), &
3290 &aai(nblz,mmul),bbi(nblz,mmul)
3291 common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
3292 common/damp/damp,ampt
3293 common/ttime/tlim,time0,time1
3294 double precision tasm
3295 common/tasm/tasm(6,6)
3296 integer iv,ixv,nlostp,nms,numxv
3297 double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
3298 &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
3299 &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl, &
3300 &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
3301 &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv, &
3302 &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas, &
3303 &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
3304 &zsiv,zsv
3305 logical pstop
3306 common/main1/ &
3307 &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz), &
3308 &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz), &
3309 &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2), &
3310 &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart), &
3311 &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart), &
3312 &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart), &
3313 &xlv(npart),zlv(npart),pstop(npart),rvv(npart), &
3314 &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
3315 common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart), &
3316 &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart), &
3317 &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart), &
3318 &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart), &
3319 &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart), &
3320 &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
3321 &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
3322 &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart), &
3323 &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
3324 common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo), &
3325 &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart), &
3326 &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6), &
3327 &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
3328 integer numx
3329 double precision e0f
3330 common/main4/ e0f,numx
3331 integer ktrack,nwri
3332 double precision dpsv1,strack,strackc,stracks
3333 common/track/ ktrack(nblz),strack(nblz),strackc(nblz), &
3334 &stracks(nblz),dpsv1(npart),nwri
3335 double precision cc,xlim,ylim
3336 parameter(cc = 1.12837916709551d0)
3337 parameter(xlim = 5.33d0)
3338 parameter(ylim = 4.29d0)
3339 dimension crkveb(npart),cikveb(npart),rho2b(npart),tkb(npart), &
3340 &r2b(npart),rb(npart),rkb(npart), &
3341 &xrb(npart),zrb(npart),xbb(npart),zbb(npart),crxb(npart), &
3342 &crzb(npart),cbxb(npart),cbzb(npart)
3343 integer max_ncoll,max_npart,maxn,numeff,outlun,nc
3344 !UPGRADE January 2005
3345 ! PARAMETER (MAX_NCOLL=68,MAX_NPART=20000,nc=32,NUMEFF=19,
3346 parameter (max_ncoll=100,max_npart=20000,nc=32,numeff=19, &
3347 &maxn=20000,outlun=54)
3348 !
3349 ! THIS BLOCK IS COMMON TO BOTH THIN6D AND TRAUTHIN SUBROUTINES
3350 !
3351 integer ieff
3352 !
3353 double precision myemitx0,myemity0,myalphay,mybetay,myalphax, &
3354 &mybetax,rselect
3355 common /ralph/ myemitx0,myemity0,myalphax,myalphay,mybetax, &
3356 &mybetay,rselect
3357 !
3358 integer absorbed(npart),counted(npart,numeff)
3359 double precision neff(numeff),rsig(numeff)
3360 common /eff/ neff,rsig,counted,absorbed
3361 !
3362 integer nimpact(50)
3363 double precision sumimpact(50),sqsumimpact(50)
3364 common /rimpact/ sumimpact,sqsumimpact,nimpact
3365 !
3366 integer nampl(nblz)
3367 character*16 ename(nblz)
3368 double precision sum_ax(nblz),sqsum_ax(nblz),sum_ay(nblz), &
3369 &sqsum_ay(nblz),sampl(nblz)
3370 common /ampl_rev/ sum_ax,sqsum_ax,sum_ay,sqsum_ay,sampl,ename, &
3371 &nampl
3372 !
3373 double precision neffx(numeff),neffy(numeff)
3374 common /efficiency/ neffx,neffy
3375 !
3376 integer part_hit(maxn),part_abs(maxn),n_tot_absorbed,n_absorbed &
3377 &,part_select(maxn)
3378 double precision part_impact(maxn)
3379 common /stats/ part_impact,part_hit,part_abs
3380 common /n_tot_absorbed/ n_tot_absorbed,n_absorbed
3381 common /part_select/ part_select
3382 !
3383 double precision x00(maxn),xp00(maxn),y00(maxn),yp00(maxn)
3384 common /beam00/ x00,xp00,y00,yp00
3385 !
3386 logical firstrun
3387 common /firstrun/ firstrun
3388 !
3389 integer nsurvive,nsurvive_end,num_selhit,n_impact
3390 common /outcoll/ nsurvive,num_selhit,n_impact,nsurvive_end
3391 !
3392 integer napx00
3393 common /napx00/ napx00
3394 !
3395 integer icoll
3396 common /icoll/ icoll
3397 !
3398 !UPGRADE January 2005
3399 ! INTEGER DB_NCOLL
3400 integer db_ncoll
3401 !
3402 ! For re-initializtion of random generator
3403 integer mclock_liar
3404 !
3405 character*16 db_name1(max_ncoll),db_name2(max_ncoll)
3406 character*6 db_material(max_ncoll)
3407 double precision db_nsig(max_ncoll),db_length(max_ncoll), &
3408 &db_offset(max_ncoll),db_rotation(max_ncoll), &
3409 &db_bx(max_ncoll),db_by(max_ncoll),db_tilt(max_ncoll,2), &
3410 &db_elense_thickness(max_ncoll),db_elense_j_e(max_ncoll)
3411 &,db_cry_rcurv(max_ncoll),db_cry_rmax(max_ncoll), &
3412 &db_cry_zmax(max_ncoll),db_cry_alayer(max_ncoll), &
3413 &db_cry_orient(max_ncoll),db_cry_tilt(max_ncoll)
3414 &,db_miscut(max_ncoll)
3415 common /colldatabase/ db_nsig,db_length,db_rotation,db_offset, &
3416 &db_bx,db_by,db_tilt,db_name1,db_name2,db_material,db_ncoll, &
3417 &db_elense_thickness,db_elense_j_e
3418 &,db_cry_rcurv,db_cry_rmax,db_cry_zmax,db_cry_alayer,db_cry_orient,&
3419 &db_cry_tilt,db_miscut
3420 !
3421 integer cn_impact(max_ncoll),cn_absorbed(max_ncoll)
3422 double precision caverage(max_ncoll),csigma(max_ncoll)
3423 common /collsummary/ caverage,csigma,cn_impact,cn_absorbed
3424 !
3425 double precision myx(maxn),myxp(maxn),myy(maxn),myyp(maxn), &
3426 &myp(maxn),mys(maxn)
3427 common /coord/ myx,myxp,myy,myyp,myp,mys
3428 !
3429 integer counted_r(maxn,numeff),counted_x(maxn,numeff), &
3430 &counted_y(maxn,numeff), &
3431 &ieffmax_r(npart),ieffmax_x(npart),ieffmax_y(npart)
3432 common /counting/ counted_r,counted_x,counted_y,ieffmax_r, &
3433 &ieffmax_x, ieffmax_y
3434 !
3435 integer secondary(maxn),tertiary(maxn),other(maxn), &
3436 &part_hit_before(maxn)
3437 double precision part_indiv(maxn),part_linteract(maxn)
3438 !
3439 integer samplenumber
3440 character*4 smpl
3441 character*80 pfile
3442 common /samplenumber/ pfile,smpl,samplenumber
3443 !
3444 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
3445 !
3446 !
3447 !
3448 logical cut_input,firstcoll,found,onesided
3449 !
3450 integer myktrack,n_gt72,n_gt80,n_gt90,nx_gt72,nx_gt80, &
3451 &ny_gt72,ny_gt80,rnd_lux,rnd_k1,rnd_k2,ios,num_surhit,numbin,ibin, &
3452 &num_selabs,iturn_last_hit,iturn_absorbed,iturn_survive,imov, &
3453 &ipart(npart),totalelem,selelem,unitnumber,distnumber,turnnumber, &
3454 &jb,myix, &
3455 &flukaname(npart)
3456 integer jjj, ijk
3457 !
3458 double precision ran_gauss, myran_gauss
3459 real rndm5,zbv
3460 !
3461 double precision c_length !length in m
3462 double precision c_rotation !rotation angle vs vertical in radian
3463 double precision c_aperture !aperture in m
3464 double precision c_offset !offset in m
3465 double precision c_tilt(2) !tilt in radian
3466 double precision cx(npart),cxp(npart),cy(npart),cyp(npart), &
3467 &cp(npart),cs(npart),rcx(npart),rcxp(npart),rcy(npart),rcyp(npart),&
3468 &rcp(npart),rcs(npart),rcx0(npart),rcxp0(npart),rcy0(npart), &
3469 &rcyp0(npart),rcp0(npart),enom_gev,totals,betax,betay,xmax,ymax, &
3470 &nsig,calc_aperture,gammax,gammay,gammax0,gammay0,gammax1,gammay1, &
3471 &xj,xpj,yj,ypj,pj,arcdx,arcbetax,xdisp,nspx,nspy,rxjco,ryjco, &
3472 &rxpjco,rypjco,dummy,mux(nblz),muy(nblz),mux0,muy0,c_rmstilt, &
3473 &c_systilt,scale_bx,scale_by,scale_bx0,scale_by0,xkick, &
3474 &ykick,bx_dist,by_dist,xmax_pencil,ymax_pencil,xmax_nom,ymax_nom, &
3475 &nom_aperture,pencil_aperture,xp_pencil(max_ncoll), &
3476 &yp_pencil(max_ncoll),x_pencil0,y_pencil0,sum,sqsum, &
3477 &csum(max_ncoll),csqsum(max_ncoll),average,sigma,sigsecut,nspxd, &
3478 &xndisp,xgrd(npart),xpgrd(npart),ygrd(npart),ypgrd(npart), &
3479 &pgrd(npart),ejfvgrd(npart),sigmvgrd(npart),rvvgrd(npart), &
3480 &dpsvgrd(npart),oidpsvgrd(npart),dpsv1grd(npart), &
3481 &ax0,ay0,bx0,by0,dnormx,dnormy,driftx,drifty, &
3482 &xnorm,xpnorm,xangle,ynorm,ypnorm,yangle,xbob(nblz),ybob(nblz), &
3483 &xpbob(nblz),ypbob(nblz),xineff(npart),yineff(npart), &
3484 &xpineff(npart),ypineff(npart),grdpiover2,grdpiover4,grd3piover4
3485 double precision x_sl(100),x1_sl(100),x2_sl(100), &
3486 & y1_sl(100), y2_sl(100), &
3487 & angle1(100), angle2(100), &
3488 & max_tmp, &
3489 & a_tmp1, a_tmp2
3490 !
3491 character*6 c_material !material
3492 !
3493 common /cut/ cut_input
3494 common /mu/ mux, muy
3495 common /xcheck/ xbob,ybob,xpbob,ypbob,xineff,yineff,xpineff, &
3496 &ypineff
3497 !
3498 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
3499 !
3500 !GRD
3501 !GRD THIS BLOC IS COMMON TO MAINCR, DATEN, TRAUTHIN AND THIN6D
3502 !GRD
3503 !APRIL2005
3504 logical do_coll,do_select,do_nominal,dowrite_dist,do_oneside, &
3505 &dowrite_impact,dowrite_secondary,dowrite_amplitude,radial, &
3506 &systilt_antisymm,dowritetracks,cern,do_nsig,do_mingap
3507 integer nloop,rnd_seed,c_offsettilt_seed,ibeam,jobnumber, &
3508 &do_thisdis,n_slices,pencil_distr
3509 double precision myenom,mynex,mdex,myney,mdey, &
3510 &nsig_tcp3,nsig_tcsg3,nsig_tcsm3,nsig_tcla3, &
3511 &nsig_tcp7,nsig_tcsg7,nsig_tcsm7,nsig_tcla7,nsig_tclp,nsig_tcli, &
3512 !
3513 &nsig_tcth1,nsig_tcth2,nsig_tcth5,nsig_tcth8, &
3514 &nsig_tctv1,nsig_tctv2,nsig_tctv5,nsig_tctv8, &
3515 !
3516 &nsig_tcdq,nsig_tcstcdq,nsig_tdi,nsig_tcxrp,nsig_tcryo, nsig_cry, &
3517 !SEPT2005 add these lines for the slicing procedure
3518 &smin_slices,smax_slices,recenter1,recenter2, &
3519 &fit1_1,fit1_2,fit1_3,fit1_4,fit1_5,fit1_6,ssf1, &
3520 &fit2_1,fit2_2,fit2_3,fit2_4,fit2_5,fit2_6,ssf2, &
3521 !SEPT2005,OCT2006 added offset
3522 &emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase, &
3523 &c_rmstilt_prim,c_rmstilt_sec,c_systilt_prim,c_systilt_sec, &
3524 &c_rmsoffset_prim,c_rmsoffset_sec,c_sysoffset_prim, &
3525 &c_sysoffset_sec,c_rmserror_gap,nr,ndr, &
3526 &driftsx,driftsy,pencil_offset,pencil_rmsx,pencil_rmsy, &
3527 &sigsecut3,sigsecut2,enerror,bunchlength
3528 !
3529 character*16 name_coll
3530 character*24 name_sel
3531 character*80 coll_db
3532 character*16 castordir
3533 character*80 filename_dis
3534 !
3535 common /grd/ myenom,mynex,mdex,myney,mdey, &
3536 &nsig_tcp3,nsig_tcsg3,nsig_tcsm3,nsig_tcla3, &
3537 &nsig_tcp7,nsig_tcsg7,nsig_tcsm7,nsig_tcla7,nsig_tclp,nsig_tcli, &
3538 !
3539 &nsig_tcth1,nsig_tcth2,nsig_tcth5,nsig_tcth8, &
3540 &nsig_tctv1,nsig_tctv2,nsig_tctv5,nsig_tctv8, &
3541 !
3542 &nsig_tcdq,nsig_tcstcdq,nsig_tdi,nsig_tcxrp,nsig_tcryo, nsig_cry, &
3543 !
3544 &smin_slices,smax_slices,recenter1,recenter2, &
3545 &fit1_1,fit1_2,fit1_3,fit1_4,fit1_5,fit1_6,ssf1, &
3546 &fit2_1,fit2_2,fit2_3,fit2_4,fit2_5,fit2_6,ssf2, &
3547 !
3548 &emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase, &
3549 &c_rmstilt_prim,c_rmstilt_sec,c_systilt_prim,c_systilt_sec, &
3550 &c_rmsoffset_prim,c_rmsoffset_sec,c_sysoffset_prim, &
3551 &c_sysoffset_sec,c_rmserror_gap,nr, &
3552 !
3553 &ndr,driftsx,driftsy,pencil_offset,pencil_rmsx,pencil_rmsy, &
3554 &sigsecut3,sigsecut2,enerror, &
3555 &bunchlength,coll_db,name_sel, &
3556 &castordir,filename_dis,nloop,rnd_seed,c_offsettilt_seed, &
3557 &ibeam,jobnumber,do_thisdis,n_slices,pencil_distr, &
3558 &do_coll, &
3559 !
3560 &do_select,do_nominal,dowrite_dist,do_oneside,dowrite_impact, &
3561 &dowrite_secondary,dowrite_amplitude,radial,systilt_antisymm, &
3562 &dowritetracks,cern,do_nsig,do_mingap
3563 !
3564 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
3565 !
3566 !
3567 ! THIS BLOCK IS COMMON TO WRITELIN,LINOPT,TRAUTHIN,THIN6D AND MAINCR
3568 !
3569 double precision tbetax(nblz),tbetay(nblz),talphax(nblz), &
3570 &talphay(nblz),torbx(nblz),torbxp(nblz),torby(nblz),torbyp(nblz), &
3571 &tdispx(nblz),tdispy(nblz)
3572 !
3573 common /rtwiss/ tbetax,tbetay,talphax,talphay,torbx,torbxp, &
3574 &torby,torbyp,tdispx,tdispy
3575 !
3576 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
3577 !
3578 ! Variables for finding the collimator with the smallest gap
3579 ! and defining, stroring the gap rms error
3580 !
3581 character*16 coll_mingap1, coll_mingap2
3582 double precision gap_rms_error(max_ncoll), nsig_err, sig_offset
3583 double precision mingap,gap_h1,gap_h2,gap_h3,gap_h4
3584 integer coll_mingap_id
3585 !
3586 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
3587 !
3588 ! THIS BLOCK IS COMMON TO THIN6D, TRAUTHIN, COLLIMATE32 AND MAINCR
3589 !
3590 integer ipencil
3591 double precision xp_pencil0,yp_pencil0,x_pencil(max_ncoll), &
3592 &y_pencil(max_ncoll),pencil_dx(max_ncoll)
3593 common /pencil/ xp_pencil0,yp_pencil0,pencil_dx,ipencil
3594 common /pencil2/ x_pencil, y_pencil
3595 !
3596 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
3597 !
3598 integer ie,iturn,nabs_total
3599 common /info/ ie,iturn,nabs_total
3600 !--September 2006 -- TW common to readcollimator and collimate2
3601 ! logical changed_tilt1(max_ncoll)
3602 ! logical changed_tilt2(max_ncoll)
3603 ! common /tilt/ changed_tilt1, changed_tilt2
3604 !--September 2006
3605 !
3606 !
3607 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
3608 ! SEPT2008 JCSMITH
3609 ! electron lense parameters
3610 integer this_elense ! which elense we are currently looking at
3611 integer, parameter :: n_elense = 10
3612 double precision elense_r_min(n_elense)
3613 double precision elense_r_max(n_elense)
3614 double precision elense_j_e(n_elense)
3615 double precision elense_length(n_elense)
3616
3617 common /elense/ elense_r_min, elense_r_max, elense_j_e, &
3618 & elense_length
3619 ! SEPT2008
3620 integer nprim
3621 !
3622 dimension dpsv3(npart)
3623 !-----------------------------------------------------------------------
3624 !SEPT 2008 valentina
3625 ! crystal parameters
3626 ! Cry_length crystal length [m]
3627 ! Rcurv curvature radius [m]
3628 ! C_xmax thickness of the crystal [m]
3629 ! C_ymax height of the crystal [m]
3630 ! Alayer thickness of amorphous layer [m]
3631 ! C_orient crystalline planes orientation
3632 ! Cry_tilt0 beam natural divergence at the crystal position
3633 ! Cry_tilt total tilt of the crystal (orientation + c_tilt0)
3634 !
3635 ! bool_proc(j) is set, for each particle, after the last passage from a
3636 ! crystal. bool_proc(j)=1: amorphous , bool_proc(j)=2: volume reflection,
3637 ! bool_proc(j)=3: channeling, bool_proc(j)=4: dechanneling
3638 ! bool_proc(j)=5: absorbed ,bool_proc(j)=6: volume capture
3639 !
3640 ! bool_create is just to check that the distribution of particles has
3641 ! alredy been created
3642 !
3643 ! write_c_out, write_SPS_out are flags to activate more output files for
3644 ! the crystal
3645 !
3646 double precision Cry_length, Rcurv,C_xmax,C_ymax,Alayer,C_orient
3647 double precision Cry_Bending
3648 double precision miscut !miscut angle in rad
3649 common/miscut/ miscut
3650 common /Par_Cry1/ Cry_length, Rcurv,C_xmax,C_ymax,Alayer,C_orient
3651 double precision Cry_tilt,Cry_tilt0
3652 common /Par_Cry2/ Cry_tilt,Cry_tilt0
3653 integer bool_proc(maxn)
3654 integer bool_proc_old(maxn)
3655 logical bool_create
3656 logical write_c_out, write_SPS_out
3657 common /Process/ bool_proc,bool_create
3658 common /Process_old/ bool_proc_old
3659 common /outputs/ write_c_out, write_SPS_out
3660 !
3661 double precision X_NORM,XP_NORM,Y_NORM,YP_NORM
3662 !
3663
3664 double precision xdebug(nblz),xdebugN(nblz),xpdebug(nblz),
3665 & xpdebugN(nblz),
3666 & ydebug(nblz),ydebugN(nblz),ypdebug(nblz),ypdebugN(nblz)
3667 common /debugvale/xdebug,xdebugN,xpdebug,xpdebugN,
3668 &ydebug,ydebugN,ypdebug,ypdebugN
3669
3670 !
3671 double precision totals_vale
3672
3673 !---------------------------------------------------------------------------
3674 save
3675
3676 c5m4=5.0d-4
3677 nthinerr=0
3678 !++ Some initialization
3679 !
3680 do i = 1, numeff
3681 rsig(i) = dble(i)/2d0 - 0.5d0 + 6d0
3682 enddo
3683 n_gt72 = 0
3684 n_gt80 = 0
3685 n_gt90 = 0
3686 nx_gt72 = 0
3687 nx_gt80 = 0
3688 ny_gt72 = 0
3689 ny_gt80 = 0
3690 firstcoll = .true.
3691 napx = napx00
3692 do j = 1, napx
3693 part_hit(j) = 0
3694 part_abs(j) = 0
3695 part_impact(j) = 0
3696 enddo
3697 !
3698 !++ This we only do once, for the first call to this routine. Numbers
3699 !++ are saved in memory to use exactly the same info for each sample.
3700 !++ COMMON block to decide for first usage and to save coll info.
3701 !
3702 !--------------------------------------------------------------------
3703 !++ Read collimator database
3704 if (firstrun) then
3705 !
3706 call readcollimator
3707 !
3708 write(*,*) 'number of collimators', db_ncoll
3709 do icoll = 1, db_ncoll
3710 write(*,*) 'COLLIMATOR', icoll, ' ', db_name1(icoll)
3711 write(*,*) 'collimator', icoll, ' ', db_name2(icoll)
3712 end do
3713 !******write settings for alignment error in colltrack.out file
3714 !
3715 write(outlun,*) ' '
3716 write(outlun,*) 'Alignment errors settings (tilt, offset,...)'
3717 write(outlun,*) ' '
3718 write(outlun,*) 'SETTING> c_rmstilt_prim : ', c_rmstilt_prim
3719 write(outlun,*) 'SETTING> c_rmstilt_sec : ', c_rmstilt_sec
3720 write(outlun,*) 'SETTING> c_systilt_prim : ', c_systilt_prim
3721 write(outlun,*) 'SETTING> c_systilt_sec : ', c_systilt_sec
3722 write(outlun,*) 'SETTING> c_rmsoffset_prim : ', c_rmsoffset_prim
3723 write(outlun,*) 'SETTING> c_rmsoffset_sec : ', c_rmsoffset_sec
3724 write(outlun,*) 'SETTING> c_sysoffset_prim : ', c_sysoffset_prim
3725 write(outlun,*) 'SETTING> c_sysoffset_sec : ', c_sysoffset_sec
3726 write(outlun,*) 'SETTING> c_offsettilt seed: ', c_offsettilt_seed
3727 write(outlun,*) 'SETTING> c_rmserror_gap : ', c_rmserror_gap
3728 write(outlun,*) 'SETTING> do_mingap : ', do_mingap
3729 write(outlun,*) ' '
3730 ! added offset and random_seed for tilt and offset
3731 !*****intialize random generator with offset_seed
3732 c_offsettilt_seed = abs(c_offsettilt_seed)
3733 rnd_lux = 3
3734 rnd_k1 = 0
3735 rnd_k2 = 0
3736 call rluxgo(rnd_lux, c_offsettilt_seed, rnd_k1, rnd_k2)
3737 ! write(outlun,*) 'INFO> c_offsettilt seed: ', c_offsettilt_seed
3738 !
3739 ! reset counter to assure starting at the same position in case of
3740 ! using rndm5 somewhere else in the code before
3741 !
3742 zbv = rndm5(1)
3743 !
3744 !++ Generate random tilts (Gaussian distribution plus systematic)
3745 !++ Do this only for the first call of this routine (first sample)
3746 !++ Keep all collimator database info and errors in memeory (COMMON
3747 !++ block) in order to re-use exactly the same information for every
3748 !++ sample.
3749 !
3750 if (c_rmstilt_prim.gt.0. .or. c_rmstilt_sec.gt.0. .or. &
3751 & c_systilt_prim.ne.0. .or. c_systilt_sec.ne.0.) then
3752 do icoll = 1, db_ncoll
3753 if (db_name1(icoll)(1:3).eq.'TCP') then
3754 c_rmstilt = c_rmstilt_prim
3755 c_systilt = c_systilt_prim
3756 else
3757 c_rmstilt = c_rmstilt_sec
3758 c_systilt = c_systilt_sec
3759 endif
3760 db_tilt(icoll,1) = c_systilt+c_rmstilt*myran_gauss(3d0)
3761 if (systilt_antisymm) then
3762 db_tilt(icoll,2) = &
3763 & -1d0*c_systilt+c_rmstilt*myran_gauss(3d0)
3764 else
3765 db_tilt(icoll,2) = &
3766 & c_systilt+c_rmstilt*myran_gauss(3d0)
3767 endif
3768 write(outlun,*) 'INFO> Collimator ', db_name1(icoll), &
3769 & ' jaw 1 has tilt [rad]: ', db_tilt(icoll,1)
3770 write(outlun,*) 'INFO> Collimator ', db_name1(icoll), &
3771 & ' jaw 2 has tilt [rad]: ', db_tilt(icoll,2)
3772 end do
3773 endif
3774 !++ Generate random offsets (Gaussian distribution plus systematic)
3775 !++ Do this only for the first call of this routine (first sample)
3776 !++ Keep all collimator database info and errors in memeory (COMMON
3777 !++ block) in order to re-use exactly the same information for every
3778 !++ sample and throughout a all run.
3779 if (c_sysoffset_prim.ne.0. .or. c_sysoffset_sec.ne.0. .or. &
3780 & c_rmsoffset_prim.gt.0. .or. c_rmsoffset_sec.gt.0.) then
3781 do icoll = 1, db_ncoll
3782 if (db_name1(icoll)(1:3).eq.'TCP') then
3783 db_offset(icoll) = c_sysoffset_prim + &
3784 & c_rmsoffset_prim*myran_gauss(3d0)
3785 else
3786 db_offset(icoll) = c_sysoffset_sec + &
3787 & c_rmsoffset_sec*myran_gauss(3d0)
3788 endif
3789 write(outlun,*) 'INFO> offset: ', db_name1(icoll), &
3790 & db_offset(icoll)
3791 end do
3792 endif
3793 !++ Generate random offsets (Gaussian distribution)
3794 !++ Do this only for the first call of this routine (first sample)
3795 !++ Keep all collimator database info and errors in memeory (COMMON
3796 !++ block) in order to re-use exactly the same information for every
3797 !++ sample and throughout a all run.
3798 do icoll = 1, db_ncoll
3799 gap_rms_error(icoll) = c_rmserror_gap * myran_gauss(3d0)
3800 write(outlun,*) 'INFO> gap_rms_error: ', &
3801 & db_name1(icoll),gap_rms_error(icoll)
3802 end do
3803 !
3804 !---- creating a file with beta-functions at TCP/TCS
3805 open(unit=10000, file='twisslike.out')
3806 open(unit=10001, file='sigmasettings.out')
3807 mingap = 20
3808 do j=1,iu
3809 ! this transformation gives the right marker/name to the corresponding
3810 ! beta-dunctions or vice versa ;)
3811 if(ic(j).le.nblo) then
3812 do jb=1,mel(ic(j))
3813 myix=mtyp(ic(j),jb)
3814 enddo
3815 else
3816 myix=ic(j)-nblo
3817 endif
3818 ! Using same code-block as below to evalute the collimator opening
3819 ! for each collimator, this is needed to get the smallest collimator gap
3820 ! in principal only looking for primary and secondary should be enough
3821 ! JULY 2008 added changes (V6.503) for names in TCTV -> TCTVA amd TCTVB
3822 ! both namings before and after V6.503 can be used
3823 if ( bez(myix)(1:2).eq.'TC' &
3824 & .or. bez(myix)(1:2).eq.'tc' &
3825 & .or. bez(myix)(1:2).eq.'TD' &
3826 & .or. bez(myix)(1:2).eq.'td' &
3827 & .or. bez(myix)(1:3).eq.'COL' &
3828 & .or. bez(myix)(1:3).eq.'col'
3829 & .or. bez(myix)(1:3).eq.'CRY' !valentina add crystal
3830 & .or. bez(myix)(1:3).eq.'cry') then
3831 if(bez(myix)(1:3).eq.'TCP' .or. &
3832 & bez(myix)(1:3).eq.'tcp') then
3833 if(bez(myix)(7:9).eq.'3.B' .or. &
3834 & bez(myix)(7:9).eq.'3.b') then
3835 nsig = nsig_tcp3
3836 else
3837 nsig = nsig_tcp7
3838 endif
3839 elseif(bez(myix)(1:4).eq.'TCSG' .or. &
3840 & bez(myix)(1:4).eq.'tcsg' .or.
3841 & bez(myix)(1:4).eq.'TCSP' .or.
3842 & bez(myix)(1:4).eq.'tcsp' ) then
3843 if(bez(myix)(8:10).eq.'3.B' .or. &
3844 & bez(myix)(8:10).eq.'3.b' .or. &
3845 & bez(myix)(9:11).eq.'3.B' .or. &
3846 & bez(myix)(9:11).eq.'3.b') then
3847 nsig = nsig_tcsg3
3848 else
3849 nsig = nsig_tcsg7
3850 endif
3851 if((bez(myix)(5:6).eq.'.4'.and.bez(myix)(8:9).eq.'6.')&
3852 & ) then
3853 nsig = nsig_tcstcdq
3854 endif
3855 elseif(bez(myix)(1:4).eq.'TCSM' .or. &
3856 & bez(myix)(1:4).eq.'tcsm') then
3857 if(bez(myix)(8:10).eq.'3.B' .or. &
3858 & bez(myix)(8:10).eq.'3.b' .or. &
3859 & bez(myix)(9:11).eq.'3.B' .or. &
3860 & bez(myix)(9:11).eq.'3.b') then
3861 nsig = nsig_tcsm3
3862 else
3863 nsig = nsig_tcsm7
3864 endif
3865 elseif(bez(myix)(1:4).eq.'TCLA' .or. &
3866 & bez(myix)(1:4).eq.'tcla') then
3867 if(bez(myix)(9:11).eq.'7.B' .or. &
3868 & bez(myix)(9:11).eq.'7.b') then
3869 nsig = nsig_tcla7
3870 else
3871 nsig = nsig_tcla3
3872 endif
3873 elseif(bez(myix)(1:4).eq.'TCDQ' .or. &
3874 & bez(myix)(1:4).eq.'tcdq') then
3875 nsig = nsig_tcdq
3876 elseif(bez(myix)(1:4).eq.'TCTH' .or. &
3877 & bez(myix)(1:4).eq.'tcth' ) then &
3878 if(bez(myix)(8:10).eq.'1.B' .or. &
3879 & bez(myix)(8:10).eq.'1.b') then
3880 nsig = nsig_tcth1
3881 elseif(bez(myix)(8:10).eq.'2.B' .or. &
3882 & bez(myix)(8:10).eq.'2.b') then
3883 nsig = nsig_tcth2
3884 elseif(bez(myix)(8:10).eq.'5.B' .or. &
3885 & bez(myix)(8:10).eq.'5.b') then
3886 nsig = nsig_tcth5
3887 elseif(bez(myix)(8:10).eq.'8.B' .or. &
3888 & bez(myix)(8:10).eq.'8.b') then
3889 nsig = nsig_tcth8
3890 endif
3891 elseif(bez(myix)(1:4).eq.'TCTV' .or. &
3892 & bez(myix)(1:4).eq.'tctv' ) then
3893 if(bez(myix)(8:10).eq.'1.B' .or. &
3894 & bez(myix)(8:10).eq.'1.b' .or. &
3895 & bez(myix)(9:11).eq.'1.B' .or. &
3896 & bez(myix)(9:11).eq.'1.b' ) then
3897 nsig = nsig_tctv1
3898 elseif(bez(myix)(8:10).eq.'2.B' .or. &
3899 & bez(myix)(8:10).eq.'2.b' .or. &
3900 & bez(myix)(9:11).eq.'2.B' .or. &
3901 & bez(myix)(9:11).eq.'2.b' ) then
3902 nsig = nsig_tctv2
3903 elseif(bez(myix)(8:10).eq.'5.B' .or. &
3904 & bez(myix)(8:10).eq.'5.b' .or. &
3905 & bez(myix)(9:11).eq.'5.B' .or. &
3906 & bez(myix)(9:11).eq.'5.b') then
3907 nsig = nsig_tctv5
3908 elseif(bez(myix)(8:10).eq.'8.B' .or. &
3909 & bez(myix)(8:10).eq.'8.b' .or. &
3910 & bez(myix)(9:11).eq.'8.B' .or. &
3911 & bez(myix)(9:11).eq.'8.b') then
3912 nsig = nsig_tctv8
3913 endif
3914 elseif(bez(myix)(1:3).eq.'TDI' .or. &
3915 & bez(myix)(1:3).eq.'tdi') then
3916 nsig = nsig_tdi
3917 elseif(bez(myix)(1:4).eq.'TCLP' .or. &
3918 & bez(myix)(1:4).eq.'tclp' .or. &
3919 & bez(myix)(1:4).eq.'TCL.' .or. &
3920 & bez(myix)(1:4).eq.'tcl.') then
3921 nsig = nsig_tclp
3922 elseif(bez(myix)(1:4).eq.'TCLI' .or. &
3923 & bez(myix)(1:4).eq.'tcli') then
3924 nsig = nsig_tcli
3925 elseif(bez(myix)(1:4).eq.'TCXR' .or. &
3926 & bez(myix)(1:4).eq.'tcxr') then
3927 nsig = nsig_tcxrp
3928 ! TW 04/2008 ---- start adding TCRYO
3929 elseif(bez(myix)(1:5).eq.'TCRYO' .or. &
3930 & bez(myix)(1:5).eq.'tcryo') then
3931 nsig = nsig_tcryo
3932 ! TW 04/2008 ---- end adding TCRYO
3933 ! valentina SEPT2008 ---- start adding CRY
3934 elseif(bez(myix)(1:3).eq.'CRY' .or.
3935 & bez(myix)(1:3).eq.'cry') then
3936 nsig = nsig_cry
3937 ! valentina SEPT2008 ---- end adding CRY
3938 elseif(bez(myix)(1:3).eq.'COL' .or. &
3939 & bez(myix)(1:3).eq.'col') then
3940 if(bez(myix)(1:4).eq.'COLM' .or. &
3941 & bez(myix)(1:4).eq.'colm' .or. &
3942 & bez(myix)(1:5).eq.'COLH0' .or. &
3943 & bez(myix)(1:5).eq.'colh0') then
3944 nsig = nsig_tcth1
3945 elseif(bez(myix)(1:5).eq.'COLV0' .or. &
3946 & bez(myix)(1:5).eq.'colv0') then
3947 nsig = nsig_tcth2
3948 elseif(bez(myix)(1:5).eq.'COLH1' .or. &
3949 & bez(myix)(1:5).eq.'colh1') then
3950 ! JUNE2005 HERE WE USE NSIG_TCTH2 AS THE OPENING IN THE VERTICAL
3951 ! JUNE2005 PLANE FOR THE PRIMARY COLLIMATOR OF RHIC; NSIG_TCTH5 STANDS
3952 ! JUNE2005 FOR THE OPENING OF THE FIRST SECONDARY COLLIMATOR OF RHIC
3953 nsig = nsig_tcth5
3954 elseif(bez(myix)(1:5).eq.'COLV1' .or. &
3955 & bez(myix)(1:5).eq.'colv1') then
3956 nsig = nsig_tcth8
3957 elseif(bez(myix)(1:5).eq.'COLH2' .or. &
3958 & bez(myix)(1:5).eq.'colh2') then
3959 nsig = nsig_tctv1
3960 endif
3961 ! JUNE2005 END OF DEDICATED TREATMENT OF RHIC OPENINGS
3962 endif
3963 ! FEBRUAR2007
3964 do i = 1, db_ncoll
3965 !
3966 ! start searching minimum gap
3967 !
3968 if ((db_name1(i)(1:11).eq.bez(myix)(1:11)) .or. &
3969 & (db_name2(i)(1:11).eq.bez(myix)(1:11))) then
3970 if ( db_length(i) .gt. 0d0 ) then
3971 nsig_err = nsig + gap_rms_error(i)
3972 ! jaw 1 on positive side x-axis
3973 gap_h1 = nsig_err - sin(db_tilt(i,1))* &
3974 & db_length(i)/2
3975 gap_h2 = nsig_err + sin(db_tilt(i,1))* &
3976 & db_length(i)/2
3977 ! jaw 2 on negative side of x-axis (see change of sign comapred
3978 ! to above code lines, alos have a look to setting of tilt angle)
3979 gap_h3 = nsig_err + sin(db_tilt(i,2))* &
3980 & db_length(i)/2
3981 gap_h4 = nsig_err - sin(db_tilt(i,2))* &
3982 & db_length(i)/2
3983 ! find minumum halfgap
3984 ! --- searching for smallest halfgap
3985 if (do_nominal) then
3986 bx_dist = db_bx(icoll)
3987 by_dist = db_by(icoll)
3988 else
3989 bx_dist = tbetax(j)
3990 by_dist = tbetay(j)
3991 endif
3992 sig_offset = db_offset(i) / &
3993 & (sqrt(bx_dist**2 * cos(db_rotation(i))**2 &
3994 & + by_dist**2 * sin(db_rotation(i))**2 ))
3995 write(10000,*) bez(myix),tbetax(j),tbetay(j), &
3996 & torbx(j),torby(j), nsig, gap_rms_error(i)
3997 write(10001,*) bez(myix), gap_h1, gap_h2, &
3998 & gap_h3, gap_h4, sig_offset, db_offset(i), &
3999 & nsig, gap_rms_error(i)
4000 if ((gap_h1 + sig_offset) .le. mingap) then
4001 mingap = gap_h1 + sig_offset
4002 coll_mingap_id = i
4003 coll_mingap1 = db_name1(i)
4004 coll_mingap2 = db_name2(i)
4005 elseif ((gap_h2 + sig_offset) .le. mingap) then
4006 mingap = gap_h2 + sig_offset
4007 coll_mingap_id = i
4008 coll_mingap1 = db_name1(i)
4009 coll_mingap2 = db_name2(i)
4010 elseif ((gap_h3 - sig_offset) .le. mingap) then
4011 mingap = gap_h3 - sig_offset
4012 coll_mingap_id = i
4013 coll_mingap1 = db_name1(i)
4014 coll_mingap2 = db_name2(i)
4015 elseif ((gap_h4 - sig_offset) .le. mingap) then
4016 mingap = gap_h4 - sig_offset
4017 coll_mingap_id = i
4018 coll_mingap1 = db_name1(i)
4019 coll_mingap2 = db_name2(i)
4020 endif
4021 endif
4022 endif
4023 enddo
4024 !
4025 ! could be done more elegant the above code to search the minimum gap
4026 ! and should also consider the jaw tilt
4027 !
4028 endif
4029 enddo
4030 write(10000,*) 'minimum gap collimator:',coll_mingap_id,
4031 & coll_mingap1,coll_mingap2, mingap
4032 write(10000,*) 'INFO> IPENCIL initial ',ipencil
4033 ! if pencil beam is used and on collimator with smallest gap the
4034 ! distribution should be generated, set ipencil to coll_mingap_id
4035 if (ipencil.gt.0 .and. do_mingap) then
4036 ipencil = coll_mingap_id
4037 endif
4038 write(10000,*) 'INFO> IPENCIL new (if do_mingap) ',ipencil
4039 ! ---
4040 write(10001,*) coll_mingap_id,coll_mingap1,coll_mingap2, &
4041 & mingap
4042 ! if pencil beam is used and on collimator with smallest gap the
4043 ! distribution should be generated, set ipencil to coll_mingap_id
4044 write(10001,*) 'INFO> IPENCIL new (if do_mingap) ',ipencil
4045 write(10001,*) 'INFO> rnd_seed is (before reinit)',rnd_seed
4046 !
4047 close(10000)
4048 close(10001)
4049 !
4050 !****** re-intialize random generator with rnd_seed
4051 ! reinit with initial value used in first call
4052 rnd_lux = 3
4053 rnd_k1 = 0
4054 rnd_k2 = 0
4055 call rluxgo(rnd_lux, rnd_seed, rnd_k1, rnd_k2)
4056 !
4057 !GRD
4058 !GRD INITIALIZE LOCAL ADDITIVE PARAMETERS, ie THE ONE WE DON'T WANT
4059 !GRD TO KEEP OVER EACH LOOP
4060 !GRD
4061 do j=1,napx
4062 tertiary(j)=0
4063 secondary(j)=0
4064 other(j)=0
4065 end do
4066 !GRD
4067 do k = 1, numeff
4068 neff(k) = 0d0
4069 neffx(k) = 0d0
4070 neffy(k) = 0d0
4071 enddo
4072 !
4073 !Mars 2005
4074 do j=1,max_ncoll
4075 cn_impact(j) = 0
4076 cn_absorbed(j) = 0
4077 csum(j) = 0d0
4078 csqsum(j) = 0d0
4079 enddo
4080 !Mars 2005
4081 !++ End of first call stuff (end of first run)
4082 !
4083 endif
4084 !
4085 !++ Moved initialization to the start of EACH set, RA/GRD 14/6/04
4086 !
4087 do j=1,napx
4088 tertiary(j)=0
4089 secondary(j)=0
4090 !APRIL2005
4091 other(j)=0
4092 !APRIL2005
4093 end do
4094 !GRD
4095 !GRD HERE WE INITIALIZE THE VALUES OF IPART(j)
4096 !GRD
4097 do j=1,napx
4098 ipart(j) = j
4099 flukaname(j) = 0
4100 end do
4101 !GRD
4102 !GRD NOW WE CAN BEGIN THE LOOPS
4103 !GRD
4104 open(unit=99,file='betatron.dat')
4105 do 660 n=1,numl
4106 iturn=n
4107 numx=n-1
4108 if(irip.eq.1) call ripple(n)
4109 if(mod(numx,nwri).eq.0) call writebin(nthinerr)
4110 if(nthinerr.ne.0) return
4111 totals=0d0
4112 totals_vale=0d0
4113 do 650 i=1,iu
4114 ie=i
4115 !
4116 !++ For absorbed particles set all coordinates to zero. Also
4117 !++ include very large offsets, let's say above 100mm or
4118 !++ 100mrad.
4119 !
4120 do j = 1, napx
4121 if (part_abs(j).gt.0 .or. &
4122 &xv(1,j).gt.100d0 .or. &
4123 &yv(1,j).gt.100d0 .or. &
4124 &xv(2,j).gt.100d0 .or. &
4125 &yv(2,j).gt.100d0) then
4126 xv(1,j) = 0d0
4127 yv(1,j) = 0d0
4128 xv(2,j) = 0d0
4129 yv(2,j) = 0d0
4130 ejv(j) = myenom
4131 sigmv(j)= 0d0
4132 part_abs(j) = 10000*ie + iturn
4133 secondary(j) = 0
4134 tertiary(j) = 0
4135 other(j) = 0
4136 endif
4137 end do
4138 !GRD
4139 !GRD SAVE COORDINATES OF PARTICLE 1 TO CHECK ORBIT
4140 !GRD
4141 if(firstrun) then
4142 xbob(ie)=xv(1,1)
4143 !xbob [mm] is the transverse coordinate of the first particle
4144 !of the first bunch at the first turn
4145 ybob(ie)=xv(2,1)
4146 xpbob(ie)=yv(1,1)
4147 ypbob(ie)=yv(2,1)
4148 endif
4149 !++ Here comes sixtrack stuff
4150 !
4151 if(ic(i).le.nblo) then
4152 do jb=1,mel(ic(i))
4153 myix=mtyp(ic(i),jb)
4154 enddo
4155 else
4156 myix=ic(i)-nblo
4157 endif
4158 ix=ic(i)-nblo
4159 !++ Make sure we go into collimation routine for any definition
4160 !++ of collimator element, relying on element name instead.
4161 !
4162 if ( &
4163 !GRD HERE ARE SOME CHANGES TO MAKE RHIC TRAKING AVAILABLE
4164 & (bez(myix)(1:3).eq.'TCP'.or.bez(myix)(1:3).eq.'tcp') .or. &
4165 & (bez(myix)(1:3).eq.'TCS'.or.bez(myix)(1:3).eq.'tcs') .or. &
4166 & (bez(myix)(1:3).eq.'TCL'.or.bez(myix)(1:3).eq.'tcl') .or. &
4167 & (bez(myix)(1:3).eq.'TCT'.or.bez(myix)(1:3).eq.'tct') .or. &
4168 & (bez(myix)(1:3).eq.'TCD'.or.bez(myix)(1:3).eq.'tcd') .or. &
4169 & (bez(myix)(1:3).eq.'TDI'.or.bez(myix)(1:3).eq.'tdi') .or. &
4170 & (bez(myix)(1:3).eq.'TCX'.or.bez(myix)(1:3).eq.'tcx') .or. &
4171 & (bez(myix)(1:3).eq.'TCR'.or.bez(myix)(1:3).eq.'tcr') .or. &
4172 & (bez(myix)(1:3).eq.'COL'.or.bez(myix)(1:3).eq.'col') .or. &
4173 & (bez(myix)(1:5).eq.'ELENS'.or.bez(myix)(1:5).eq.'elens') .or. &
4174 & (bez(myix)(1:3).eq.'CRY'.or.bez(myix)(1:3).eq.'cry') ) then
4175 myktrack = 1
4176 else
4177 myktrack = ktrack(i)
4178 endif
4179 c if (n .eq.1 .and. i.eq.1 )
4180 c & write(9999,*)"1=elem 2=npart 3=s 4=betax 5=alphax 6=x 7=y ",
4181 c & "8=xp 9=yp 10=xnorm 11=ynorm 12=xpnorm 13=ypnorm 14=amplx",
4182 c & "15=dispx 16=energy 17=orbx 18=orbx"
4183 if (myktrack.eq.1) then
4184 totals_vale=totals_vale+strack(i)
4185 if (strack(i).lt.0) write(*,*)"WARN:lenght <0!!!!,el=",ie
4186 & ,bez(myix),myktrack
4187 c
4188 c do j = 1, napx
4189 c write(9999,*) i,j,
4190 c & totals_vale,tbetax(ie),talphax(ie)
4191 c & ,xv(1,j),xv(2,j),yv(1,j),yv(2,j),
4192 c & xv(1,j)/sqrt(myemitx0*tbetax(ie))/1d3,
4193 c & xv(2,j)/sqrt(myemity0*tbetay(ie))/1d3,
4194 c & (xv(1,j)/1d3*talphax(ie)+yv(1,j)/1d3*tbetax(ie))
4195 c & /sqrt(myemitx0*tbetax(ie)),
4196 c & (xv(2,j)/1d3*talphay(ie)+yv(2,j)/1d3*tbetay(ie))
4197 c & /sqrt(myemity0*tbetay(ie)),
4198 c & sqrt((xv(1,j)/sqrt(myemitx0*tbetax(ie))/1d3)**2 +
4199 c & ((xv(1,j)/1d3*talphax(ie)+yv(1,j)/1d3*tbetax(ie))
4200 c & /sqrt(myemitx0*tbetax(ie)))**2),tdispx(ie),ejv(j)
4201 c & ,torbx(ie),torby(ie)
4202 c enddo
4203 endif
4204 goto(10,30,740,650,650,650,650,650,650,650,50,70,90,110,130, &
4205 &150,170,190,210,230,440,460,480,500,520,540,560,580,600,620, &
4206 &640,410,250,270,290,310,330,350,370,390,680,700,720,730,748, &
4207 &650,650,650,650,650,745,746),myktrack
4208 goto 650
4209 10 stracki=strack(i)
4210 !==========================================
4211 !Ralph drift length is stracki
4212 !bez(ix) is name of drift
4213 totals=totals+stracki
4214 !________________________________________________________________________
4215 !++ If we have a collimator then...
4216 !
4217 !Feb2006
4218 !GRD (June 2005) 'COL' option is for RHIC collimators
4219 !
4220 ! SR (17-01-2006): Special assignment to the TCS.TCDQ for B1 and B4,
4221 ! using the new naming as in V6.500.
4222 ! Note that this must be in the loop "if TCSG"!!
4223 !
4224 ! SR, 17-01-2006: Review the TCT assignments because the MADX names
4225 ! have changes (TCTH.L -> TCTH.4L)
4226 !
4227 ! JULY 2008 added changes (V6.503) for names in TCTV -> TCTVA amd TCTVB
4228 ! both namings before and after V6.503 can be used
4229 !
4230 !SEPT2008 JCSMITH
4231 ! Added electorn lense collimator
4232 !
4233 !SEPT2008 valentina
4234 ! Added crystal collimator
4235 if (do_coll .and.
4236 & (bez(myix)(1:2).eq.'TC'
4237 & .or. bez(myix)(1:2).eq.'tc'
4238 & .or. bez(myix)(1:2).eq.'TD'
4239 & .or. bez(myix)(1:2).eq.'td'
4240 & .or. bez(myix)(1:5).eq.'ELENS'
4241 & .or. bez(myix)(1:5).eq.'elens'
4242 & .or. bez(myix)(1:3).eq.'CRY'
4243 & .or. bez(myix)(1:3).eq.'cry'
4244 & .or. bez(myix)(1:3).eq.'COL'
4245 & .or. bez(myix)(1:3).eq.'col')) then
4246 if(bez(myix)(1:3).eq.'TCP' .or. &
4247 & bez(myix)(1:3).eq.'tcp') then
4248 if(bez(myix)(7:9).eq.'3.B' .or. &
4249 & bez(myix)(7:9).eq.'3.b') then
4250 nsig = nsig_tcp3
4251 else
4252 nsig = nsig_tcp7
4253 endif
4254 elseif(bez(myix)(1:4).eq.'TCSG' .or. &
4255 & bez(myix)(1:4).eq.'tcsg' .or.
4256 & bez(myix)(1:4).eq.'TCSP' .or.
4257 & bez(myix)(1:4).eq.'tcsp' ) then
4258 if(bez(myix)(8:10).eq.'3.B' .or. &
4259 & bez(myix)(8:10).eq.'3.b' .or. &
4260 & bez(myix)(9:11).eq.'3.B' .or. &
4261 & bez(myix)(9:11).eq.'3.b') then
4262 nsig = nsig_tcsg3
4263 else
4264 nsig = nsig_tcsg7
4265 endif
4266 if((bez(myix)(5:6).eq.'.4'.and.
4267 & bez(myix)(8:9).eq.'6.')
4268 & ) then
4269 nsig = nsig_tcstcdq
4270 endif
4271 elseif(bez(myix)(1:4).eq.'TCSM' .or. &
4272 & bez(myix)(1:4).eq.'tcsm') then
4273 if(bez(myix)(8:10).eq.'3.B' .or. &
4274 & bez(myix)(8:10).eq.'3.b' .or. &
4275 & bez(myix)(9:11).eq.'3.B' .or. &
4276 & bez(myix)(9:11).eq.'3.b') then
4277 nsig = nsig_tcsm3
4278 else
4279 nsig = nsig_tcsm7
4280 endif
4281 elseif(bez(myix)(1:4).eq.'TCLA' .or. &
4282 & bez(myix)(1:4).eq.'tcla') then
4283 if(bez(myix)(9:11).eq.'7.B' .or. &
4284 & bez(myix)(9:11).eq.'7.b') then
4285 nsig = nsig_tcla7
4286 else
4287 nsig = nsig_tcla3
4288 endif
4289 elseif(bez(myix)(1:4).eq.'TCDQ' .or. &
4290 & bez(myix)(1:4).eq.'tcdq') then
4291 nsig = nsig_tcdq
4292 elseif(bez(myix)(1:4).eq.'TCTH' .or. &
4293 & bez(myix)(1:4).eq.'tcth' ) then &
4294 if(bez(myix)(8:10).eq.'1.B' .or. &
4295 & bez(myix)(8:10).eq.'1.b') then
4296 nsig = nsig_tcth1
4297 elseif(bez(myix)(8:10).eq.'2.B' .or. &
4298 & bez(myix)(8:10).eq.'2.b') then
4299 nsig = nsig_tcth2
4300 elseif(bez(myix)(8:10).eq.'5.B' .or. &
4301 & bez(myix)(8:10).eq.'5.b') then
4302 nsig = nsig_tcth5
4303 elseif(bez(myix)(8:10).eq.'8.B' .or. &
4304 & bez(myix)(8:10).eq.'8.b') then
4305 nsig = nsig_tcth8
4306 endif
4307 elseif(bez(myix)(1:4).eq.'TCTV' .or. &
4308 & bez(myix)(1:4).eq.'tctv' ) then
4309 if(bez(myix)(8:10).eq.'1.B' .or. &
4310 & bez(myix)(8:10).eq.'1.b' .or. &
4311 & bez(myix)(9:11).eq.'1.B' .or. &
4312 & bez(myix)(9:11).eq.'1.b' ) then
4313 nsig = nsig_tctv1
4314 elseif(bez(myix)(8:10).eq.'2.B' .or. &
4315 & bez(myix)(8:10).eq.'2.b' .or. &
4316 & bez(myix)(9:11).eq.'2.B' .or. &
4317 & bez(myix)(9:11).eq.'2.b' ) then
4318 nsig = nsig_tctv2
4319 elseif(bez(myix)(8:10).eq.'5.B' .or. &
4320 & bez(myix)(8:10).eq.'5.b' .or. &
4321 & bez(myix)(9:11).eq.'5.B' .or. &
4322 & bez(myix)(9:11).eq.'5.b') then
4323 nsig = nsig_tctv5
4324 elseif(bez(myix)(8:10).eq.'8.B' .or. &
4325 & bez(myix)(8:10).eq.'8.b' .or. &
4326 & bez(myix)(9:11).eq.'8.B' .or. &
4327 & bez(myix)(9:11).eq.'8.b') then
4328 nsig = nsig_tctv8
4329 endif
4330 elseif(bez(myix)(1:3).eq.'TDI' .or. &
4331 & bez(myix)(1:3).eq.'tdi') then
4332 nsig = nsig_tdi
4333 elseif(bez(myix)(1:4).eq.'TCLP' .or. &
4334 & bez(myix)(1:4).eq.'tclp' .or. &
4335 & bez(myix)(1:4).eq.'TCL.' .or. &
4336 & bez(myix)(1:4).eq.'tcl.') then
4337 nsig = nsig_tclp
4338 elseif(bez(myix)(1:4).eq.'TCLI' .or. &
4339 & bez(myix)(1:4).eq.'tcli') then
4340 nsig = nsig_tcli
4341 elseif(bez(myix)(1:4).eq.'TCXR' .or. &
4342 & bez(myix)(1:4).eq.'tcxr') then
4343 nsig = nsig_tcxrp
4344 elseif(bez(myix)(1:5).eq.'TCRYO' .or. &
4345 & bez(myix)(1:5).eq.'tcryo') then
4346 nsig = nsig_tcryo
4347 elseif(bez(myix)(1:3).eq.'CRY' .or. &
4348 & bez(myix)(1:3).eq.'cry') then
4349 nsig = nsig_cry
4350 elseif(bez(myix)(1:3).eq.'COL' .or. &
4351 & bez(myix)(1:3).eq.'col') then
4352 if(bez(myix)(1:4).eq.'COLM' .or. &
4353 & bez(myix)(1:4).eq.'colm' .or. &
4354 & bez(myix)(1:5).eq.'COLH0' .or. &
4355 & bez(myix)(1:5).eq.'colh0') then
4356 nsig = nsig_tcth1
4357 elseif(bez(myix)(1:5).eq.'COLV0' .or. &
4358 & bez(myix)(1:5).eq.'colv0') then
4359 nsig = nsig_tcth2
4360 elseif(bez(myix)(1:5).eq.'COLH1' .or. &
4361 & bez(myix)(1:5).eq.'colh1') then
4362 ! JUNE2005 HERE WE USE NSIG_TCTH2 AS THE OPENING IN THE VERTICAL
4363 ! JUNE2005 PLANE FOR THE PRIMARY COLLIMATOR OF RHIC; NSIG_TCTH5 STANDS
4364 ! JUNE2005 FOR THE OPENING OF THE FIRST SECONDARY COLLIMATOR OF RHIC
4365 nsig = nsig_tcth5
4366 elseif(bez(myix)(1:5).eq.'COLV1' .or. &
4367 & bez(myix)(1:5).eq.'colv1') then
4368 nsig = nsig_tcth8
4369 elseif(bez(myix)(1:5).eq.'COLH2' .or. &
4370 & bez(myix)(1:5).eq.'colh2') then
4371 nsig = nsig_tctv1
4372 endif
4373 endif
4374
4375 !
4376 !++ Write trajectory for any selected particle
4377 !
4378 c_length = 0d0
4379 !
4380 !Feb2006
4381 ! SR, 23-11-2005: To avoid binary entries in 'amplitude.dat'
4382 if ( firstrun ) then
4383 !
4384 if (rselect.gt.0 .and. rselect.lt.65) then
4385 !
4386 do j = 1, napx
4387 !
4388 xj = (xv(1,j)-torbx(ie))/1d3
4389 xpj = (yv(1,j)-torbxp(ie))/1d3
4390 yj = (xv(2,j)-torby(ie))/1d3
4391 ypj = (yv(2,j)-torbyp(ie))/1d3
4392 pj = ejv(j)/1d3
4393 if (iturn.eq.1.and.j.eq.1) then
4394 sum_ax(ie)=0d0
4395 sum_ay(ie)=0d0
4396 endif
4397 if (stracki.eq.0.) then
4398 xj = xj + 0.5d0*c_length*xpj
4399 yj = yj + 0.5d0*c_length*ypj
4400 endif
4401 gammax = (1d0 + talphax(ie)**2)/
4402 & tbetax(ie)
4403 gammay = (1d0 + talphay(ie)**2)/
4404 & tbetay(ie)
4405 if (part_abs(j).eq.0) then
4406 xdebug(ie)=xj
4407 xpdebug(ie)=xpj
4408 ydebug(ie)=yj
4409 ypdebug(ie)=ypj
4410 xdebugN(ie)= xdebug(ie)
4411 & /sqrt(myemitx0*tbetax(ie))
4412 xpdebugN(ie)=(xdebug(ie)*
4413 & talphax(ie)+xpdebug(ie)*
4414 & tbetax(ie))
4415 & /sqrt(myemitx0*tbetax(ie))
4416 ydebugN(ie)=ydebug(ie)
4417 & /sqrt(myemity0*tbetay(ie))
4418 ypdebugN(ie)=(ydebug(ie)*
4419 & talphay(ie)+ypdebug(ie)*
4420 & tbetay(ie))
4421 & /sqrt(myemity0*tbetay(ie))
4422 nspx = sqrt( &
4423 & abs( gammax*(xj)**2 + &
4424 & 2d0*talphax(ie)*xj*xpj + &
4425 & tbetax(ie)*xpj**2 )/myemitx0 &
4426 & )
4427 nspy = sqrt( &
4428 & abs( gammay*(yj)**2 + &
4429 & 2d0*talphay(ie)*yj*ypj + &
4430 & tbetay(ie)*ypj**2 )/myemity0 &
4431 & )
4432 sum_ax(ie) = sum_ax(ie) + nspx
4433 sqsum_ax(ie)=sqsum_ax(ie)+nspx**2
4434 sum_ay(ie) = sum_ay(ie) + nspy
4435 sqsum_ay(ie)=sqsum_ay(ie)+nspy**2
4436 nampl(ie) = nampl(ie) + 1
4437 else
4438 nspx = 0d0
4439 nspy = 0d0
4440 endif
4441 sampl(ie) = totals
4442 ename(ie) = bez(myix)(1:16)
4443 end do
4444 endif
4445 endif
4446 !GRD------------------------------------------------------------------------
4447 !GRD HERE WE LOOK FOR ADEQUATE DATABASE INFORMATION
4448 !GRD------------------------------------------------------------------------
4449 found = .false.
4450 do j = 1, db_ncoll
4451 if ((db_name1(j)(1:11).eq.bez(myix)(1:11)) .or. &
4452 & (db_name2(j)(1:11).eq.bez(myix)(1:11))) then
4453 if ( db_length(j) .gt. 0d0 ) then
4454 found = .true.
4455 icoll = j
4456 endif
4457 endif
4458 end do
4459 c if (.not. found .and. firstrun) then
4460 c write(*,*) 'ERR> Collimator not found: ', bez(myix)
4461 c endif
4462
4463 !
4464 !++ For known collimators
4465 !
4466 if (found) then
4467 !-----------------------------------------------------------------------
4468 !GRD
4469 !GRD NEW COLLIMATION PARAMETERS
4470 !GRD
4471 !-----------------------------------------------------------------------
4472 !++ Get the aperture from the beta functions and emittance
4473 !++ A simple estimate of beta beating can be included that
4474 !++ has twice the betatron phase advance
4475 !
4476 !Mars 2005
4477 if(.not. do_nsig) nsig = db_nsig(icoll)
4478 !Mars 2005
4479 scale_bx = (1d0 + xbeat*sin(4*pi*mux(ie)+ &
4480 & xbeatphase) )
4481 scale_by = (1d0 + ybeat*sin(4*pi*muy(ie)+ &
4482 & ybeatphase) )
4483 !
4484 if (firstcoll) then
4485 scale_bx0 = scale_bx
4486 scale_by0 = scale_by
4487 firstcoll = .false.
4488 endif
4489 !
4490 !-------------------------------------------------------------------
4491 !++ Assign nominal OR design beta functions for later
4492 !
4493
4494 if (do_nominal) then
4495 bx_dist = db_bx(icoll) * scale_bx / scale_bx0
4496 by_dist = db_by(icoll) * scale_by / scale_by0
4497 else
4498 bx_dist = tbetax(ie) * scale_bx / scale_bx0
4499 by_dist = tbetay(ie) * scale_by / scale_by0
4500 endif
4501 !
4502 !-------------------------------------------------------------------
4503 !++ Write beam ellipse at selected collimator
4504 ! ---- changed name_sel(1:11) name_sel(1:12) to be checked if feasible!!
4505 if ( &
4506 & ((db_name1(icoll)(1:11) .eq.name_sel(1:11)) &
4507 & .or.(db_name2(icoll)(1:11) .eq.name_sel(1:11))) &
4508 & .and. dowrite_dist) then
4509 do j = 1, napx
4510 write(45,'(6(1X,E15.7),1X,I4,6(1X,E15.7
4511 & ))') xv(1,j), xv(2,j), yv(1,j), yv(2,j),
4512 & ejv(j), mys(j),iturn,
4513 & xv(1,j)/1000/sqrt(tbetax(ie)*myemitx0),
4514 & xv(2,j)/1000/sqrt(tbetay(ie)*myemity0),
4515 & (xv(1,j)/1000*talphax(ie)+yv(1,j)/1000*
4516 & tbetax(ie))/sqrt(tbetax(ie)*myemitx0),
4517 & (xv(2,j)/1000*talphax(ie)+ yv(2,j)/1000*
4518 & tbetay(ie))/sqrt(tbetay(ie)*myemity0),
4519 & sqrt((xv(1,j)/1000/sqrt(tbetax(ie)*
4520 & myemitx0))**2+((xv(1,j)/1000*talphax(ie)
4521 & +yv(1,j)/1000*tbetax(ie))/
4522 & sqrt(tbetax(ie)*myemitx0))**2)
4523 & ,sqrt((xv(2,j)/1000/sqrt(tbetay(ie)*
4524 & myemity0))**2+((xv(2,j)/1000*
4525 & talphax(ie)+yv(2,j)/1000*tbetay(ie))/
4526 & sqrt(tbetay(ie)*myemity0))**2)
4527 &
4528 end do
4529 endif
4530
4531 !
4532 !-------------------------------------------------------------------
4533 !++ Output to temporary database and screen
4534 !
4535 if (iturn.eq.1.and.firstrun) then
4536 write(40,*) '# '
4537 write(40,*) db_name1(icoll)(1:11)
4538 write(40,*) db_material(icoll)
4539 write(40,*) db_length(icoll)
4540 write(40,*) db_rotation(icoll)
4541 write(40,*) db_offset(icoll)
4542 write(40,*) tbetax(ie)
4543 write(40,*) tbetay(ie)
4544 !
4545 write(outlun,*) ' '
4546 write(outlun,*) 'Collimator information: '
4547 write(outlun,*) ' '
4548 write(outlun,*) 'Name: ' &
4549 & , db_name1(icoll)(1:11)
4550 write(outlun,*) 'Material: ' &
4551 & , db_material(icoll)
4552 write(outlun,*) 'Length [m]: ' &
4553 & , db_length(icoll)
4554 write(outlun,*) 'Rotation [rad]: ' &
4555 & , db_rotation(icoll)
4556 write(outlun,*) 'Offset [m]: ' &
4557 & ,db_offset(icoll)
4558 write(outlun,*) 'Design beta x [m]: ' &
4559 & ,db_bx(icoll)
4560 write(outlun,*) 'Design beta y [m]: ' &
4561 & ,db_by(icoll)
4562 write(outlun,*) 'Optics beta x [m]: ' &
4563 & ,tbetax(ie)
4564 write(outlun,*) 'Optics beta y [m]: ' &
4565 & ,tbetay(ie)
4566 endif
4567 !
4568 !-------------------------------------------------------------------
4569 !++ Calculate aperture of collimator
4570 !
4571 if(db_name1(icoll)(1:4).ne.'COLM') then
4572 nsig = nsig + gap_rms_error(icoll)
4573 xmax = nsig*sqrt(bx_dist*myemitx0)
4574 ymax = nsig*sqrt(by_dist*myemity0)
4575 xmax_pencil = (nsig+pencil_offset)* &
4576 & sqrt(bx_dist*myemitx0)
4577 ymax_pencil = (nsig+pencil_offset)* &
4578 & sqrt(by_dist*myemity0)
4579 xmax_nom = db_nsig(icoll)*sqrt(db_bx(icoll)
4580 & *myemitx0)
4581 ymax_nom = db_nsig(icoll)*sqrt(db_by(icoll)
4582 & *myemity0)
4583 c_rotation = db_rotation(icoll)
4584 c_length = db_length(icoll)
4585 c_material = db_material(icoll)
4586 c_offset = db_offset(icoll)
4587 c_tilt(1) = db_tilt(icoll,1)
4588 c_tilt(2) = db_tilt(icoll,2)
4589 c----- valentina ---------------------------------------------
4590 c Orient the crystal with the beam divergence
4591 if (DB_NAME1(icoll)(1:3).EQ.'CRY') then !aligning the crystal with the divergence of the beam in that point
4592 if (DB_ROTATION(ICOLL).eq.0) then
4593 Cry_tilt0= -1.*sqrt(myemitx0
4594 & /tbetax(ie))*talphaX(ie)*nsig
4595 elseif (DB_ROTATION(ICOLL).GT.1.5) then !for the moment I have just hor and vertical crystals
4596 Cry_tilt0 =-1.*sqrt(myemity0/
4597 & tbetay(ie))*talphay(ie)* nsig
4598 write(*,*) 'vertical crystal'
4599 endif
4600
4601 Cry_length=db_length(icoll)
4602 C_xmax=db_cry_rmax(icoll)
4603 C_ymax=db_cry_zmax(icoll)
4604 C_orient=db_cry_orient(icoll)
4605 Alayer=db_cry_alayer(icoll)
4606 miscut=db_miscut(icoll)
4607 c write(*,*)"from db miscut",miscut
4608 Cry_tilt = DB_CRY_TILT(ICOLL)+Cry_tilt0 ! the total alignment of the crystal
4609 Cry_bending=DB_LENGTH(ICOLL)
4610 & /DB_CRY_RCURV(ICOLL)
4611 Rcurv = DB_CRY_RCURV(ICOLL)
4612 if (Cry_tilt .ge. -Cry_bending ) then
4613 C_LENGTH=Rcurv*(SIN(Cry_bending+Cry_tilt)
4614 & - SIN(Cry_tilt))
4615 else
4616 C_LENGTH=Rcurv*(SIN(Cry_bending-Cry_tilt)
4617 & + SIN(Cry_tilt))
4618 endif
4619 c IF(ITURN.eq.1)write(*,*)'div. @ cry: ',
4620 c 1 Cry_tilt0,'tilt DB:',DB_CRY_TILT(ICOLL),
4621 c 2 "total tilt Cry_tilt",Cry_tilt
4622 c write(*,*)"debug track.f; c_length",
4623 c & C_LENGTH
4624
4625 c write(*,*)"crystal bending = ", Cry_bending
4626 c write(*,*)"crystal lenght = ", C_LENGTH
4627 c write(*,*)"cry tilt = ", Cry_tilt,"=",DB_CRY_TILT(ICOLL),
4628 c 1 "+",Cry_tilt0
4629 endif
4630 c----------------------------------------------------------------------
4631
4632
4633 calc_aperture =sqrt( xmax**2 *cos(c_rotation)**2
4634 & + ymax**2 * sin(c_rotation)**2 )
4635 nom_aperture=sqrt(xmax_nom**2*cos(c_rotation)**2
4636 & + ymax_nom**2 * sin(c_rotation)**2 )
4637 !
4638 pencil_aperture =
4639 & sqrt( xmax_pencil**2 * cos(c_rotation)**2
4640 & + ymax_pencil**2 * sin(c_rotation)**2 )
4641 !
4642 !++ Get x and y offsets at collimator center point
4643 !
4644 x_pencil(icoll) = xmax_pencil *(cos(c_rotation))
4645 y_pencil(icoll) = ymax_pencil *(sin(c_rotation))
4646 !
4647 !++ Get corresponding beam angles (uses xp_max)
4648 !
4649 xp_pencil(icoll) =
4650 & -1d0 * sqrt(myemitx0/tbetax(ie))*talphax(ie)
4651 & * xmax / sqrt(myemitx0*tbetax(ie))
4652 !
4653 yp_pencil(icoll) =
4654 & -1d0 * sqrt(myemity0/tbetay(ie))*talphay(ie)
4655 & * ymax / sqrt(myemity0*tbetay(ie))
4656 !
4657 xp_pencil0 = xp_pencil(icoll)
4658 yp_pencil0 = yp_pencil(icoll)
4659 !
4660 pencil_dx(icoll) =
4661 & sqrt( xmax_pencil**2 * cos(c_rotation)**2
4662 & + ymax_pencil**2 * sin(c_rotation)**2 )
4663 & - calc_aperture
4664 !++ TW -- tilt for of jaw for pencil beam
4665 !++ as in Ralphs orig routine, but not in collimate subroutine itself
4666 ! nprim = 3
4667 ! if ( (icoll.eq.ipencil) &
4668 ! & icoll.le.nprim .and. (j.ge.(icoll-1)*nev/nprim) &
4669 ! & .and. (j.le.(icoll)*nev/nprim))) then
4670 ! this is done for every bunch (64 particle bucket)
4671 ! important: Sixtrack calculates in "mm" and collimate2 in "m"
4672 ! therefore 1E-3 is used to
4673 if ((icoll.eq.ipencil).and.(iturn.eq.1)) then
4674 !! write(*,*) " ************************************** "
4675 !! write(*,*) " * INFO> seting tilt for pencil beam * "
4676 !! write(*,*) " ************************************** "
4677 c_tilt(1) =c_tilt(1)+(xp_pencil0*cos(
4678 & c_rotation)+sin(c_rotation)*yp_pencil0)
4679 write(*,*)
4680 & "INFO> Changed tilt1 ICOLL to ANGLE: ",
4681 & icoll, c_tilt(1)
4682 !
4683 !! respects if the tilt symmetric or not, for systilt_antiymm c_tilt is
4684 !! -systilt + rmstilt otherwise +systilt + rmstilt
4685 !! if (systilt_antisymm) then
4686 !! to align the jaw/pencil to the beam always use the minus regardless which
4687 !! orientation of the jaws was used (symmetric/antisymmetric)
4688 c_tilt(2) = c_tilt(2) -1.*(xp_pencil0
4689 & *cos(c_rotation)+ sin(c_rotation)*
4690 & yp_pencil0)
4691 write(*,*)
4692 & "INFO> Changed tilt2 ICOLL to ANGLE: ",
4693 & icoll, c_tilt(2)
4694 endif
4695 !++ TW -- tilt angle changed (added to genetated on if spec. in fort.3)
4696 !JUNE2005 HERE IS THE SPECIAL TREATMENT...
4697 elseif(db_name1(icoll)(1:4).eq.'COLM') then
4698 !
4699 xmax = nsig_tcth1*sqrt(bx_dist*myemitx0)
4700 !
4701 c_rotation = db_rotation(icoll)
4702 c_length = db_length(icoll)
4703 c_material = db_material(icoll)
4704 c_offset = db_offset(icoll)
4705 c_tilt(1) = db_tilt(icoll,1)
4706 c_tilt(2) = db_tilt(icoll,2)
4707 !
4708 !DEBUG
4709 ! calc_aperture = sqrt( xmax**2 * cos(c_rotation)**2 &
4710 ! & + ymax**2 * sin(c_rotation)**2 )
4711 calc_aperture = xmax
4712 !
4713 ! nom_aperture = sqrt( xmax**2 * cos(c_rotation-(pi/2d0))**2 &
4714 ! & + ymax**2 * sin(c_rotation-(pi/2d0))**2 )
4715 nom_aperture = ymax
4716 !
4717 !DEBUG
4718 ! write(*,*) 'GRD'
4719 ! write(*,*) 'openings of colmark'
4720 ! write(*,*) 'hori_SIG: ',nsig_tcth1,' vert_SIG: ',nsig_tcth2
4721 ! write(*,*) 'xmax: ',xmax,' ymax: ',ymax
4722 ! write(*,*) 'trigo: ',cos(c_rotation),cos(c_rotation-(pi/2d0)), &
4723 ! & sin(c_rotation),sin(c_rotation-(pi/2d0))
4724 ! write(*,*) 'hori_M: ',calc_aperture,' vert_M: ',nom_aperture
4725 ! write(*,*) 'GRD'
4726 !DEBUG
4727 endif
4728 !
4729 !-------------------------------------------------------------------
4730 !++ Further output
4731 !
4732 if(firstrun) then
4733 if (iturn.eq.1) then
4734 write(outlun,*) xp_pencil(icoll),
4735 & yp_pencil(icoll),pencil_dx(icoll)
4736 write(outlun,'(a,i4)')
4737 & 'Collimator number: ',icoll
4738 write(outlun,*)
4739 & 'Beam size x [m]: ',sqrt(tbetax(ie)*
4740 & myemitx0)
4741 write(outlun,*) 'Beam size y [m]: '
4742 & ,sqrt(tbetay(ie)*myemity0)
4743 write(outlun,*)
4744 & 'Divergence x [urad]: ',
4745 & 1d6*xp_pencil(icoll)
4746 write(outlun,*)
4747 & 'Divergence y [urad]: ',
4748 & 1d6*yp_pencil(icoll)
4749 write(outlun,*) 'Aperture (nom) [m]: '
4750 & ,nom_aperture
4751 write(outlun,*) 'Aperture (cal) [m]: '
4752 & ,calc_aperture
4753 write(outlun,*)
4754 & 'Collimator halfgap [sigma]: ',nsig
4755 write(outlun,*)
4756 & 'RMS error on halfgap [sigma]: '
4757 & ,gap_rms_error(icoll)
4758 write(outlun,*) ' '
4759 write(43,'(i7.5,1x,a,4(1x,e13.5),1x,a,
4760 & 6(1x,e13.5))')icoll,
4761 & db_name1(icoll)(1:12),db_rotation(icoll)
4762 & ,tbetax(ie), tbetay(ie), calc_aperture,
4763 & db_material(icoll),db_length(icoll),
4764 & sqrt(tbetax(ie)*myemitx0),
4765 & sqrt(tbetay(ie)*myemity0),
4766 & db_tilt(icoll,1),db_tilt(icoll,2), nsig
4767 if ( n_slices.le.1 .or.
4768 & db_name1(icoll)(1:3) .eq. 'CRY' ) then
4769 write(55,'(a,1x,i7.5,5(1x,e13.5),1x,a)')
4770 & db_name1(icoll),
4771 & 1,calc_aperture,
4772 & db_offset(icoll),
4773 & db_tilt(icoll,1),
4774 & db_tilt(icoll,2),
4775 & db_length(icoll),
4776 & db_material(icoll)
4777 endif
4778
4779 endif
4780
4781 endif
4782 !
4783 !++ Assign aperture which we define as the FULL width (factor 2)!!!
4784 !
4785 !JUNE2005 AGAIN, SOME SPECIFIC STUFF FOR RHIC
4786 if(db_name1(icoll)(1:4).eq.'COLM') then
4787 nom_aperture = 2d0*nom_aperture
4788 endif
4789 c_aperture = 2d0*calc_aperture
4790 !
4791 !GRD-------------------------------------------------------------------
4792 c if(firstrun.and.iturn.eq.1.and.icoll.eq.7) then
4793 c open(unit=99,file='distsec')
4794 c do j=1,napx
4795 c write(99,'(4(1X,E15.7))') xv(1,j),yv(1,j),xv(2,j),yv(2,j)
4796 c enddo
4797 c close(99)
4798 c endif
4799 !GRD-------------------------------------------------------------------
4800 !++ Copy particle data to 1-dim array and go back to meters
4801 !
4802 do j = 1, napx
4803 rcx(j) = (xv(1,j)-torbx(ie))/1d3
4804 rcxp(j) = (yv(1,j)-torbxp(ie))/1d3
4805 rcy(j) = (xv(2,j)-torby(ie))/1d3
4806 rcyp(j) = (yv(2,j)-torbyp(ie))/1d3
4807 rcp(j) = ejv(j)/1d3
4808 rcs(j) = 0d0
4809 part_hit_before(j) = part_hit(j)
4810 rcx0(j) = rcx(j)
4811 rcxp0(j) = rcxp(j)
4812 rcy0(j) = rcy(j)
4813 rcyp0(j) = rcyp(j)
4814 rcp0(j) = rcp(j)
4815 ejf0v(j) = ejfv(j)
4816 !
4817 !++ For zero length element track back half collimator length
4818 !
4819 if (stracki.eq.0.) then
4820 rcx(j) = rcx(j) - 0.5d0*c_length*rcxp(j)
4821 rcy(j)= rcy(j) - 0.5d0*c_length*rcyp(j)
4822 else
4823 Write(*,*)
4824 & "ERROR: Non-zero length collimator!"
4825 STOP
4826 endif
4827 flukaname(j) = ipart(j)+100*samplenumber
4828 !
4829 end do
4830 !
4831 !++ Do the collimation tracking
4832 !
4833 enom_gev = myenom*1d-3
4834 !
4835 !++ Allow primaries to be one-sided, if requested
4836 !
4837 if (((db_name1(icoll)(1:3).eq.'TCP' .or.
4838 & db_name1(icoll)(1:3).eq.'COL' .or.
4839 & db_name1(icoll)(1:4).eq.'TCSP' )
4840 & .and. do_oneside)
4841 & .or. (db_name1(icoll)(1:3).eq.'CRY')) then
4842 !SEPT2008 valentina: cry is always one sided
4843 onesided = .true.
4844 else
4845 onesided = .false.
4846 endif
4847 !
4848 !Force the treatment of the TCDQ equipment as a onsided collimator.
4849 !Both for Beam 1 and Beam 2, the TCDQ is at positive x side.
4850 ! if(db_name1(icoll)(1:4).eq.'TCDQ' ) onesided = .true.
4851 ! to treat all collimators onesided
4852 ! -> only for worst case TCDQ studies
4853 if(db_name1(icoll)(1:5).eq.'TCXRP') onesided = .true.
4854 if(db_name1(icoll)(1:11).eq.'TCP.1MM.EXP')
4855 1 onesided = .true. !scraper for the UA9 experiment
4856 if(db_name1(icoll)(1:4).eq.'TCDQ') onesided = .true.
4857 !
4858 if (found) then
4859 !
4860 if(db_name1(icoll)(1:4).eq.'COLM') then
4861 !
4862 call collimaterhic(c_material,
4863 & c_length, c_rotation,
4864 & c_aperture, nom_aperture,
4865 & c_offset, c_tilt,
4866 & rcx, rcxp, rcy, rcyp, rcp, rcs,
4867 & napx,enom_gev,part_hit,part_abs,
4868 & part_impact, part_indiv,
4869 & part_linteract, onesided,
4870 & flukaname)
4871
4872 !------- valentina SEPT 2008------------------------------
4873 ! add crystal collimation routine
4874
4875 elseif (db_name1(icoll)(1:3).eq.'CRY') then
4876 c write(*,*)"debug miscut collimate",miscut
4877 call collimate_cry ( db_name1(icoll) ,
4878 & C_MATERIAL, C_LENGTH, C_ROTATION,
4879 1 C_APERTURE, C_OFFSET, C_TILT,
4880 1 rcx, rcxp, rcy, rcyp, rcp, rcs,
4881 2 napx,enom_gev, part_hit,
4882 3 PART_ABS, part_impact, part_indiv,
4883 & part_linteract,tbetax(ie),talphax(ie),
4884 & tbetay(ie),talphay(ie),EMITX0,EMITY0,
4885 6 flukaname, secondary,dowrite_impact)
4886 c------------- ----------- ------------------------- ----------
4887 !SEPT2008 JCSMITH
4888 ! add in electron lense collimator
4889 elseif (db_name1(icoll)(1:5).eq.'ELENS') then
4890 call collimate_elense (
4891 & db_elense_thickness(icoll),
4892 & db_elense_j_e(icoll),c_length,c_rotation
4893 & ,c_aperture, c_offset, c_tilt, rcx, rcxp
4894 & ,rcy, rcyp,rcp, rcs, napx, enom_gev,
4895 & part_hit, part_abs, part_impact,
4896 & part_indiv, part_linteract, flukaname)
4897 !
4898 ! SR, 29-08-2005: Slice the collimator jaws in 'n_slices' pieces
4899 ! using two 4th-order polynomial fits. For each slices, the new
4900 ! gaps and centre are calculates
4901 ! It is assumed that the jaw point closer to the beam defines the
4902 ! nominal aperture.
4903 !
4904 ! SR, 01-09-2005: new official version - input assigned through
4905 ! the 'fort.3' file.
4906 !CB
4907 elseif (n_slices.gt.1d0 .and.
4908 & (db_name1(icoll)(1:4).eq.'TCSG'
4909 & .or. db_name1(icoll)(1:3).eq.'TCP'
4910 & .or. db_name1(icoll)(1:4).eq.'TCLA'
4911 & .or. db_name1(icoll)(1:3).eq.'TCT'
4912 & .or. db_name1(icoll)(1:4).eq.'TCLI'
4913 & .or. db_name1(icoll)(1:4).eq.'TCSP'
4914 & .or. db_name1(icoll)(1:4).eq.'TCL.')) then
4915 if (firstrun) then
4916 write(*,*)
4917 & 'INFO> slice - Collimator ',
4918 & db_name1(icoll), ' sliced in ',
4919 & n_slices,' pieces!'
4920 endif
4921 !! In this preliminary try, all secondary collimators are sliced.
4922 !! Slice only collimators with finite length!!
4923 !! Slice the primaries, to have more statistics faster!
4924 !!
4925 !! Calculate longitudinal positions of slices and corresponding heights
4926 !! and angles from the fit parameters.
4927 !! -> MY NOTATION: y1_sl: jaw at x > 0; y2_sl: jaw at x < 0;
4928 !! Note: here, take (n_slices+1) points in order to calculate the
4929 !! tilt angle of the last slice!!
4930 ! CB:10-2007 deformation of the jaws scaled with length
4931 do jjj=1,n_slices+1
4932 x_sl(jjj) = (jjj-1) * c_length/
4933 & dble(n_slices)
4934 y1_sl(jjj) = fit1_1 +
4935 & fit1_2*x_sl(jjj) +
4936 & fit1_3/c_length*(x_sl(jjj)**2)+
4937 & fit1_4*(x_sl(jjj)**3) +
4938 & fit1_5*(x_sl(jjj)**4) +
4939 & fit1_6*(x_sl(jjj)**5)
4940 !
4941 y2_sl(jjj) = -1d0 * (fit2_1 +
4942 & fit2_2*x_sl(jjj) +
4943 & fit2_3/c_length*(x_sl(jjj)**2)+
4944 & fit2_4*(x_sl(jjj)**3) +
4945 & fit2_5*(x_sl(jjj)**4) +
4946 & fit2_6*(x_sl(jjj)**5))
4947 enddo
4948 ! Apply the slicing scaling factors (ssf's):
4949 !
4950 ! do jjj=1,n_slices+1
4951 ! y1_sl(jjj) = ssf1 * y1_sl(jjj)
4952 ! y2_sl(jjj) = ssf2 * y2_sl(jjj)
4953 ! enddo
4954 !
4955 ! CB:10-2007 coordinates rotated of the tilt
4956 do jjj=1,n_slices+1
4957 y1_sl(jjj) = ssf1 * y1_sl(jjj)
4958 y2_sl(jjj) = ssf2 * y2_sl(jjj)
4959 ! CB code
4960 x1_sl(jjj)=x_sl(jjj)*
4961 & cos(db_tilt(icoll,1))-
4962 & y1_sl(jjj)*sin(db_tilt(icoll,1))
4963 x2_sl(jjj)=x_sl(jjj)*
4964 & cos(db_tilt(icoll,2))-
4965 & y2_sl(jjj)*sin(db_tilt(icoll,2))
4966 y1_sl(jjj) = y1_sl(jjj)*
4967 & cos(db_tilt(icoll,1))+
4968 & x_sl(jjj)*sin(db_tilt(icoll,1))
4969 y2_sl(jjj) = y2_sl(jjj)*
4970 & cos(db_tilt(icoll,2))+
4971 & x_sl(jjj)*sin(db_tilt(icoll,2))
4972 enddo
4973 ! Sign of the angle defined differently for the two jaws!
4974 do jjj=1,n_slices
4975 angle1(jjj) = ((y1_sl(jjj+1)-
4976 & y1_sl(jjj))
4977 & /( x1_sl(jjj+1)-x1_sl(jjj) ))
4978 angle2(jjj) =(( y2_sl(jjj+1)-
4979 & y2_sl(jjj))
4980 & /( x2_sl(jjj+1)-x2_sl(jjj) ))
4981 enddo
4982 !
4983 ! Sign of the angle defined differently for the two jaws!
4984 ! For both jaws, look for the 'deepest' point (closest point to beam)
4985 ! Then, shift the vectors such that this closest point defines
4986 ! the nominal aperture
4987 ! Index here must go up to (n_slices+1) in case the last point is the
4988 ! closest (and also for the later calculation of 'a_tmp1' and 'a_tmp2')
4989 !
4990 ! SR, 01-09-2005: add the recentring flag, as given in 'fort.3' to
4991 ! choose whether recentre the deepest point or not
4992 max_tmp = 1e6
4993 do jjj=1, n_slices+1
4994 if ( y1_sl(jjj).lt.max_tmp )then
4995 max_tmp = y1_sl(jjj)
4996 endif
4997 enddo
4998 do jjj=1, n_slices+1
4999 y1_sl(jjj) = y1_sl(jjj) -max_tmp
5000 & * recenter1+ 0.5 *c_aperture
5001 enddo
5002 max_tmp = -1e6
5003 do jjj=1, n_slices+1
5004 if ( y2_sl(jjj).gt.max_tmp )then
5005 max_tmp = y2_sl(jjj)
5006 endif
5007 enddo
5008 do jjj=1, n_slices+1
5009 y2_sl(jjj) = y2_sl(jjj) -max_tmp
5010 & * recenter2- 0.5 *c_aperture
5011 enddo
5012 !
5013 !! Check the collimator jaw surfaces (beam frame, before taking into
5014 !! account the azimuthal angle of the collimator)
5015 if (firstrun) write(*,*)
5016 & 'Slicing collimator ',db_name1(icoll)
5017
5018 !
5019 ! Now, loop over the number of slices and call collimate2 each time!
5020 ! For each slice, the corresponding offset and angle are to be used.
5021 do jjj=1,n_slices
5022 !
5023 ! First calculate aperture and centre of the slice
5024 ! Note that:
5025 ! (1)due to our notation for the angle sign,
5026 ! the rotation point of the slice (index j or j+1)
5027 ! DEPENDS on the angle value!!
5028 ! (2) New version of 'collimate2' is required: one must pass
5029 ! the slice number in order the calculate correctly the 's'
5030 ! coordinate in the impact files.
5031 !
5032 ! Here, 'a_tmp1' and 'a_tmp2' are, for each slice, the closest
5033 ! corners to the beam
5034 if ( angle1(jjj).gt.0d0 ) then
5035 a_tmp1 = y1_sl(jjj)
5036 else
5037 a_tmp1 = y1_sl(jjj+1)
5038 endif
5039 if ( angle2(jjj).lt.0d0 ) then
5040 a_tmp2 = y2_sl(jjj)
5041 else
5042 a_tmp2 = y2_sl(jjj+1)
5043 endif
5044 !! Write down the information on slice centre and offset
5045 !!
5046 ! Be careful! the initial tilt must be added!
5047 ! We leave it like this for the moment (no initial tilt)
5048 ! c_tilt(1) = c_tilt(1) + angle1(jjj)
5049 ! c_tilt(2) = c_tilt(2) + angle2(jjj)
5050 c_tilt(1) = angle1(jjj)
5051 c_tilt(2) = angle2(jjj)
5052 ! New version of 'collimate2' is required: one must pass the
5053 ! slice number in order the calculate correctly the 's'
5054 ! coordinate in the impact files.
5055 ! + a_tmp1 - a_tmp2,
5056 ! + 0.5 * ( a_tmp1 + a_tmp2 ),
5057 ! -- TW SEP07 added compatility for tilt, gap and ofset errors to slicing
5058 ! -- TW gaprms error is already included in the c_aperture used above
5059 ! -- TW tilt error is added to y1_sl and y2_sl therfore included in
5060 ! -- TW angle1 and angle2 no additinal changes needed
5061 ! -- TW offset error directly added to call of collimate2
5062 if (firstrun) then
5063 write(55,'(a,1x,i7.5,
5064 & 5(1x,e13.5),1x ,a)')
5065 & db_name1(icoll)(1:12),
5066 & jjj,(a_tmp1 - a_tmp2)
5067 & /2d0,0.5*(a_tmp1+a_tmp2)
5068 & +c_offset, c_tilt(1),
5069 & c_tilt(2),
5070 & c_length/dble(n_slices),
5071 & db_material(icoll)
5072 endif
5073 name_coll=db_name1(icoll)
5074 call collimate2(name_coll,
5075 & c_material,
5076 & c_length/dble(n_slices),
5077 & c_rotation, a_tmp1 - a_tmp2,
5078 & 0.5 * ( a_tmp1 + a_tmp2 )
5079 & + c_offset, c_tilt, rcx, rcxp,
5080 & rcy, rcyp,rcp, rcs, napx,
5081 & enom_gev,part_hit, part_abs,
5082 & part_impact, part_indiv,
5083 & part_linteract, onesided,
5084 & flukaname,secondary, jjj)
5085 enddo
5086 else
5087 ! Treatment of non-sliced collimators!
5088 name_coll=db_name1(icoll)
5089 call collimate2(name_coll,
5090 & c_material, c_length, c_rotation,
5091 & c_aperture, c_offset, c_tilt, rcx, rcxp,
5092 & rcy, rcyp,rcp, rcs, napx, enom_gev,
5093 & part_hit, part_abs, part_impact,
5094 & part_indiv, part_linteract,
5095 & onesided, flukaname, secondary, 1)
5096 endif
5097 ! end of check for 'found'
5098 endif
5099 !++ Output information:
5100 !++ PART_HIT(MAX_NPART) Hit flag for last hit (10000*element# + turn#)
5101 !++ PART_ABS(MAX_NPART) Abs flag (10000*element# + turn#)
5102 !++ PART_IMPACT(MAX_NPART) Impact parameter (0 for inner face)
5103 !++ PART_INDIV(MAX_NPART) Divergence of impacting particles
5104 !------------------------------------------------------------------------------
5105 !++ Calculate average impact parameter and save info for all
5106 !++ collimators. Copy information back and do negative drift.
5107 n_impact = 0
5108 n_absorbed = 0
5109 sum = 0d0
5110 sqsum = 0d0
5111 !++ Copy particle data back and do path length stuff; check for absorption
5112 !++ Add orbit offset back.
5113 do j = 1, napx
5114 !APRIL2005 IN ORDER TO GET RID OF NUMERICAL ERRORS, JUST DO THE TREATMENT FOR
5115 !APRIL2005 IMPACTING PARTICLES...
5116 if (part_hit(j).eq.(10000*ie+iturn)) then
5117 !++ For zero length element track back half collimator length
5118 if (stracki.eq.0.) then
5119 rcx(j) = rcx(j) -
5120 & 0.5d0*c_length*rcxp(j)
5121 rcy(j) = rcy(j) -
5122 & 0.5d0*c_length*rcyp(j)
5123 endif
5124 c------------------write initial-final coordinates for crystal -----------------------
5125 !SEPT2008 valentina: write special output files for cry
5126 if (write_c_out .and.
5127 1 DB_NAME1(ICOLL)(1:3).EQ.'CRY'
5128 1 ) THEN
5129 c- initial coordinatesi
5130 WRITE(881,'(i7,i4,2x,i4,2x,i4,
5131 & 2x,a,2x,5(f15.8,2x))')
5132 1 ipart(j)+100*samplenumber,ITURN,
5133 & bool_proc_old(j),ICOLL,
5134 2 DB_MATERIAL(ICOLL),rcx0(J),
5135 & rcxp0(J),rcy0(j),rcyp0(J),rcP0(J)!write down real and noormalized coordinates
5136 2 !before and after the crystal
5137 X_NORM=rcx0(J)/ SQRT(tbetax(ie))
5138 & /sqrt(myEMITX0)
5139 XP_NORM=(rcx0(J)*talphax(IE) +
5140 & rcxp0(J)*tbetax(IE))/
5141 1 SQRT(tbetax(ie))/ sqrt(myEMITX0)
5142 Y_NORM=rcY0(J)/ SQRT(tbetay(ie))
5143 & /sqrt(myEMITY0)
5144 YP_NORM=(rcY0(J)*talphay(IE) +
5145 & rcyp0(J)*tbetay(IE))/
5146 1 SQRT(tbetay(ie))/ sqrt(myEMITY0)
5147
5148 WRITE(883,'(i7,i4,2x,i4,2x,i4,2x
5149 & ,a,2x,7(f15.8,2x))')
5150 2 ipart(j)+100*samplenumber,ITURN,
5151 & bool_proc_old(j),ICOLL,
5152 3 DB_MATERIAL(ICOLL),X_NORM,
5153 & XP_NORM,Y_NORM,YP_NORM,
5154 & SQRT(X_NORM**2+XP_NORM**2),
5155 5 SQRT(Y_NORM**2+YP_NORM**2),
5156 & rcP0(j)
5157 if (part_abs(j) .eq. 0) then
5158 WRITE(882,'(i7,4(i4,2x)
5159 & ,a,2x,5(f15.8,2x))')
5160 1 ipart(j)+100*samplenumber,
5161 2 ITURN,bool_proc_old(j),
5162 & bool_proc(j),ICOLL,
5163 2 DB_MATERIAL(ICOLL),rcX(J),
5164 2 rcXP(J),rcY(J),rcYP(J),rcP(J)
5165 c
5166 X_NORM =rcX(J)/SQRT(tbetax(ie)
5167 & )/sqrt(myEMITX0)
5168 XP_NORM = (rcX(J)*talphax(IE)+
5169 & rcXP(J)*tbetax(IE))/SQRT(
5170 1 tbetax(ie))/ sqrt(myEMITX0)
5171 Y_NORM =rcY(J)/SQRT(tbetay(ie)
5172 & )/sqrt(myEMITY0)
5173 YP_NORM = (rcY(J)*talphay(IE)+
5174 & rcYP(J)*tbetay(IE))/SQRT(
5175 1 tbetay(ie))/ sqrt(myEMITY0)
5176
5177 WRITE(884,'(i7,4(i4,2x),a,2x,
5178 & 7(f15.8,2x))') ipart(j)+100*
5179 & samplenumber, ITURN ,
5180 & bool_proc_old(j),bool_proc(j),
5181 3 ICOLL,DB_MATERIAL(ICOLL)
5182 3 ,X_NORM,XP_NORM, Y_NORM,
5183 3 YP_NORM,SQRT(X_NORM**2+
5184 & XP_NORM**2),SQRT(Y_NORM**2+
5185 4 YP_NORM**2), rcP(j)
5186
5187 write(885,*)
5188 1 ipart(j)+100*samplenumber,
5189 2 ITURN,bool_proc_old(j),
5190 & bool_proc(j),ICOLL,
5191 2 DB_MATERIAL(ICOLL),
5192 & rcx0(J),rcxp0(J),
5193 & rcy0(J),rcyp0(J),!write down real and noormalized coordinates
5194 & rcXP(J)-rcXP0(J),
5195 & rcYP(J)-rcYP0(J),
5196 & rcp0(J)-rcp(j),
5197 & c_aperture,cry_tilt0
5198 endif
5199 endif
5200 c--------------------------------------------------------------------------
5201 c
5202
5203 !++ Now copy data back to original verctor
5204
5205 xv(1,j) = rcx(j)*1d3 +torbx(ie)
5206 yv(1,j) = rcxp(j)*1d3 +torbxp(ie)
5207 xv(2,j) = rcy(j)*1d3 +torby(ie)
5208 yv(2,j) = rcyp(j)*1d3 +torbyp(ie)
5209 ejv(j) = rcp(j)*1d3
5210 !
5211 !
5212 !++ Energy update, as recommended by Frank
5213 !
5214 ejfv(j)=sqrt(ejv(j)*ejv(j)-pma*pma)
5215 rvv(j)=(ejv(j)*e0f)/(e0*ejfv(j))
5216 dpsv(j)=(ejfv(j)-e0f)/e0f
5217 oidpsv(j)=one/(one+dpsv(j))
5218 dpsv1(j)=dpsv(j)*c1e3*oidpsv(j)
5219 yv(1,j)=ejf0v(j)/ejfv(j)*yv(1,j)
5220 yv(2,j)=ejf0v(j)/ejfv(j)*yv(2,j)
5221 !APRIL2005 ...OTHERWISE JUST GET BACK FORMER COORDINATES
5222 else
5223 xv(1,j) = rcx0(j)*1d3+torbx(ie)
5224 yv(1,j) = rcxp0(j)*1d3+torbxp(ie)
5225 xv(2,j) = rcy0(j)*1d3+torby(ie)
5226 yv(2,j) = rcyp0(j)*1d3+torbyp(ie)
5227 ejv(j) = rcp0(j)*1d3
5228 endif
5229 !
5230 !++ Write trajectory for any selected particle
5231 !
5232 if (firstrun) then
5233 if (rselect.gt.0 .and. rselect.lt.65) then
5234 xj = (xv(1,j)-torbx(ie))/1d3
5235 xpj = (yv(1,j)-torbxp(ie))/1d3
5236 yj = (xv(2,j)-torby(ie))/1d3
5237 ypj = (yv(2,j)-torbyp(ie))/1d3
5238 pj = ejv(j)/1d3
5239 if (iturn.eq.1.and.j.eq.1) then
5240 sum_ax(ie)=0d0
5241 sum_ay(ie)=0d0
5242 endif
5243 gammax=(1d0 + talphax(ie)**2)/tbetax(ie)
5244 gammay=(1d0 + talphay(ie)**2)/tbetay(ie)
5245 if (part_abs(j).eq.0) then
5246 xdebug(ie)=xj
5247 xpdebug(ie)=xpj
5248 ydebug(ie)=yj
5249 ypdebug(ie)=ypj
5250 xdebugN(ie)= xdebug(ie)
5251 & /sqrt(myemitx0*tbetax(ie))
5252 xpdebugN(ie)=(xdebug(ie)
5253 & *talphax(ie)+xpdebug(ie)*tbetax(ie))
5254 & /sqrt(myemitx0*tbetax(ie))
5255 ydebugN(ie)=ydebug(ie)/sqrt(
5256 & myemity0*tbetay(ie))
5257 ypdebugN(ie)=(ydebug(ie)*
5258 & talphay(ie)+ypdebug(ie)*
5259 & tbetay(ie))
5260 & /sqrt(myemity0*tbetay(ie))
5261
5262 nspx = sqrt(
5263 & abs( gammax*(xj)**2 +
5264 & 2d0*talphax(ie)*xj*xpj +
5265 & tbetax(ie)*xpj**2 )/myemitx0)
5266 nspy = sqrt(
5267 & abs( gammay*(yj)**2 +
5268 & 2d0*talphay(ie)*yj*ypj +
5269 & tbetay(ie)*ypj**2 )/myemity0)
5270 sum_ax(ie) = sum_ax(ie) + nspx
5271 sqsum_ax(ie)=sqsum_ax(ie)+nspx**2
5272 sum_ay(ie) = sum_ay(ie) + nspy
5273 sqsum_ay(ie)=sqsum_ay(ie)+nspy**2
5274 nampl(ie) = nampl(ie) + 1
5275 else
5276 nspx = 0d0
5277 nspy = 0d0
5278 endif
5279 sampl(ie) = totals
5280 ename(ie) = bez(myix)(1:16)
5281 endif
5282 endif
5283 !++ First check for particle interaction at this collimator and this turn
5284 if (part_hit(j).eq. (10000*ie+iturn)) then
5285 !++ Fill the change in particle angle into histogram
5286 if(dowrite_impact) then
5287 write(46,'(i8,1x,i4,1x,f8.2)')ipart(j)
5288 & +100*samplenumber,iturn,sampl(ie)
5289 endif
5290 if(part_abs(j).ne.0) then
5291 if(dowrite_impact)
5292 & write(47,'(i8,1x,i4,1x,f8.2)')
5293 & ipart(j)+100*samplenumber,iturn,
5294 & sampl(ie)
5295 write(38,'(1x,i8,1x,i4,1x,f8.2,
5296 & 5(1x,e11.3),1x,i4)')
5297 & ipart(j)+100*samplenumber,iturn,
5298 & sampl(ie)-0.5*c_length,
5299 & (rcx0(j)*1d3+torbx(ie))-0.5*c_length*
5300 & (rcxp0(j)*1d3+torbxp(ie)),
5301 & rcxp0(j)*1d3+torbxp(ie),
5302 & (rcy0(j)*1d3+torby(ie))-0.5*c_length*
5303 & (rcyp0(j)*1d3+torbyp(ie)),
5304 & rcyp0(j)*1d3+torbyp(ie),
5305 & (ejv(j)-myenom)/myenom,secondary(j)+
5306 & tertiary(j)+other(j)
5307 endif
5308 if (part_abs(j).eq.0) then
5309 xkick = rcxp(j) - rcxp0(j)
5310 ykick = rcyp(j) - rcyp0(j)
5311 !
5312 if (db_name1(icoll)(1:3).eq.'TCP'.or.
5313 & db_name1(icoll)(1:4).eq.'COLM'.or.
5314 & db_name1(icoll)(1:5).eq.'COLH0'.or.
5315 & db_name1(icoll)(1:5).eq.'COLV0') then
5316 secondary(j) = 1
5317 elseif(db_name1(icoll)(1:3).eq.'TCS'
5318 & .or.db_name1(icoll)(1:4).eq.'COLH1'.or.
5319 & db_name1(icoll)(1:4).eq.'COLV1'.or.
5320 & db_name1(icoll)(1:4).eq.'COLH2') then
5321 tertiary(j) = 2
5322 elseif((db_name1(icoll)(1:3).eq.'TCL')
5323 & .or.(db_name1(icoll)(1:3).eq.'TCT').or.
5324 & (db_name1(icoll)(1:3).eq.'TCD').or.
5325 & (db_name1(icoll)(1:3).eq.'TDI')) then
5326 other(j) = 4
5327 endif
5328 endif
5329 !
5330 !GRD THIS LOOP MUST NOT BE WRITTEN INTO THE "IF(FIRSTRUN)" LOOP !!!!!
5331 if (dowritetracks) then
5332 if(part_abs(j).eq.0) then
5333 if ((secondary(j).eq.1.or.
5334 & tertiary(j).eq.2.or.other(j)
5335 & .eq.4) .and.
5336 & (xv(1,j).lt.99d0 .and. xv(2,j)
5337 & .lt.99d0)
5338 & .and.
5339 !GRD HERE WE APPLY THE SAME KIND OF CUT THAN THE SIGSECUT PARAMETER
5340 & (
5341 & ((
5342 & (xv(1,j)*1d-3)**2
5343 & /(tbetax(ie)*myemitx0)
5344 & ).ge.dble(sigsecut2)).or.
5345 & ((
5346 & (xv(2,j)*1d-3)**2
5347 & /(tbetay(ie)*myemity0)
5348 & ).ge.dble(sigsecut2)).or.
5349 & (((xv(1,j)*1d-3)**2/(tbetax(ie)*
5350 & myemitx0))+((xv(2,j)*1d-3)**2/
5351 & (tbetay(ie)*myemity0))
5352 & .ge.sigsecut3)
5353 & ) ) then
5354 xj=(xv(1,j)-torbx(ie))/1d3
5355 xpj=(yv(1,j)-torbxp(ie))
5356 & /1d3
5357 yj=(xv(2,j)-torby(ie))/1d3
5358 ypj=(yv(2,j)-torbyp(ie))
5359 & /1d3
5360 write(38,'(1x,i8,1x,i4,1x,
5361 & f8.2,5(1x,e11.3),1x,i4)')
5362 & ipart(j)+100*samplenumber,
5363 & iturn,sampl(ie)-0.5*
5364 & c_length,
5365 & (rcx0(j)*1d3+torbx(ie))-0.5
5366 & *c_length*(rcxp0(j)*1d3+
5367 & torbxp(ie)),
5368 & rcxp0(j)*1d3+torbxp(ie),
5369 & (rcy0(j)*1d3+torby(ie))-0.5
5370 & *c_length*(rcyp0(j)*1d3+
5371 & torbyp(ie)),rcyp0(j)*1d3+
5372 & torbyp(ie),
5373 & (ejv(j)-myenom)/myenom,
5374 & secondary(j)+tertiary(j)+
5375 & other(j)
5376 write(38,'(1x,i8,1x,i4,1x,
5377 & f8.2,5(1x,e11.3),1x,i4)')
5378 & ipart(j)+100*samplenumber,
5379 & iturn,sampl(ie)+0.5*
5380 & c_length,xv(1,j)+0.5
5381 & *c_length*yv(1,j),yv(1,j),
5382 & xv(2,j)+0.5*c_length*
5383 & yv(2,j),yv(2,j),
5384 & (ejv(j)-myenom)/myenom,
5385 & secondary(j)+tertiary(j)
5386 & +other(j)
5387 endif
5388 endif
5389 endif
5390 !++ Calculate impact observables, fill histograms, save collimator info, ...
5391 ! OCT2008 JCSMITH
5392 ! There's something wrong here I'll try to fix it...
5393 if (abs(part_impact(j)) .lt. 0.9) then
5394 n_impact = n_impact + 1
5395 sum = sum + abs(part_impact(j))
5396 sqsum = sqsum + abs(part_impact(j))**2
5397 cn_impact(icoll) = cn_impact(icoll)+1
5398 csum(icoll) = csum(icoll) +
5399 & abs(part_impact(j))
5400 csqsum(icoll) = csqsum(icoll) +
5401 & abs(part_impact(j))**2
5402 endif
5403 !++ If the interacting particle was lost, add-up counters for absorption
5404 !++ Note: a particle with x/y >= 99. never hits anything any more in
5405 !++ the logic of this program. Be careful to always fulfill this!
5406 !
5407 if (part_abs(j).ne.0) then
5408 n_absorbed = n_absorbed + 1
5409 cn_absorbed(icoll)=cn_absorbed(icoll)+1
5410 n_tot_absorbed = n_tot_absorbed + 1
5411 iturn_last_hit = part_hit_before(j)-
5412 & int(part_hit_before(j)/10000)*10000
5413 iturn_absorbed = part_hit(j)-
5414 & int(part_hit(j)/10000)*10000
5415 if (iturn_last_hit.eq.0)
5416 & iturn_last_hit =iturn_absorbed
5417 iturn_survive = iturn_absorbed -
5418 & iturn_last_hit
5419 endif
5420 !++ End of check for hit this turn and element
5421 endif
5422 !++ Now copy the new particle momenta
5423 end do
5424 !++ Calculate statistical observables and save into files...
5425 if (n_impact.gt.0) then
5426 average = sum/n_impact
5427 if (sqsum/n_impact.ge.average**2) then
5428 sigma =sqrt(sqsum/n_impact - average**2)
5429 else
5430 sigma = 0d0
5431 endif
5432 else
5433 average = 0d0
5434 sigma = 0d0
5435 endif
5436 if (cn_impact(icoll).gt.0) then
5437 caverage(icoll) = csum(icoll)/cn_impact(icoll)
5438 if ((caverage(icoll)**2).gt.
5439 & (csqsum(icoll)/cn_impact(icoll))) then
5440 csigma(icoll) = 0
5441 else
5442 csigma(icoll) = sqrt(csqsum(icoll)/
5443 & cn_impact(icoll) - caverage(icoll)**2)
5444 endif
5445 endif
5446 !
5447 !-----------------------------------------------------------------
5448 !++ For a S E L E C T E D collimator only consider particles that
5449 !++ were scattered on this selected collimator at the first turn. All
5450 !++ other particles are discarded.
5451 !++ - This is switched on with the DO_SELECT flag in the input file.
5452 !++ - Note that the part_select(j) flag defaults to 1 for all particles.
5453 !
5454 ! should name_sel(1:11) extended to allow longer names as done for
5455 ! coll the coll_ellipse.dat file !!!!!!!!
5456 if (((db_name1(icoll)(1:10).eq.name_sel(1:10) )
5457 & .or.(db_name2(icoll)(1:10).eq.name_sel(1:10) ) )
5458 & .and. iturn.eq.1 ) then
5459 num_selhit = 0
5460 num_surhit = 0
5461 num_selabs = 0
5462 do j = 1, napx
5463 if(part_hit(j).eq.(10000*ie+iturn))then
5464 num_selhit = num_selhit+1
5465 if (part_abs(j).eq.0) then
5466 num_surhit = num_surhit+1
5467 else
5468 num_selabs = num_selabs + 1
5469 endif
5470 !++ If we want to select only partciles interacting at the specified
5471 !++ collimator then remove all other particles and reset the number
5472 !++ of the absorbed particles to the selected collimator.
5473 endif
5474 end do
5475 !++ Calculate average impact parameter and save distribution into file
5476 !++ only for selected collimator
5477 n_impact = 0
5478 sum = 0d0
5479 sqsum = 0d0
5480 do j = 1, napx
5481 if(part_hit(j).eq.(10000*ie+iturn))then
5482 if (part_impact(j).lt.-0.5d0) then
5483 write(*,*)
5484 & 'ERR> Invalid impact parameter!'
5485 & , part_impact(j)
5486 write(outlun,*)
5487 & 'ERR> Invalid impact parameter!'
5488 & , part_impact(j)
5489 stop
5490 endif
5491 n_impact = n_impact + 1
5492 sum = sum + part_impact(j)
5493 sqsum = sqsum + part_impact(j)**2
5494 if (part_hit(j).gt.0
5495 & .and. dowrite_impact) write(49,*)
5496 & part_impact(j), part_indiv(j)
5497 endif
5498 end do
5499 if (n_impact.gt.0) then
5500 average = sum/n_impact
5501 if(sqsum/n_impact.ge.average**2) then
5502 sigma=sqrt(sqsum/n_impact- average**2)
5503 else
5504 sigma = 0d0
5505 endif
5506 endif
5507 !++ Some information
5508 write(*,*)
5509 & 'INFO> Selected collimator had N hits. N: ',
5510 & num_selhit
5511 write(*,*)
5512 & 'INFO> Number of impacts : ',
5513 & n_impact
5514 write(*,*)
5515 & 'INFO> Number of escaped protons : ',
5516 & num_surhit
5517 write(*,*)
5518 & 'INFO> Average impact parameter [m] : ',
5519 & average
5520 write(*,*)
5521 &' INFO> Sigma impact parameter [m] : ',
5522 & sigma
5523 !
5524 if (dowrite_impact) close(49)
5525 !++ End of S E L E C T E D collimator
5526 endif
5527 !---------------------------------------------------------
5528 !++ End of check for known collimator
5529 endif
5530 !------------------------------------------------------------------
5531 !++ Here leave the known collimator IF loop...
5532 !_______________________________________________________________________
5533 !++ If it is just a drift...
5534 else
5535 !
5536 do 23 j=1,napx
5537 xv(1,j)=xv(1,j)+stracki*yv(1,j)
5538 xv(2,j)=xv(2,j)+stracki*yv(2,j)
5539 sigmv(j)=sigmv(j)+stracki*(c1e3-rvv(j)* &
5540 & (c1e3+(yv(1,j)*yv(1,j)+yv(2,j)*yv(2,j))*c5m4))
5541 xj = (xv(1,j)-torbx(ie))/1d3
5542 xpj = (yv(1,j)-torbxp(ie))/1d3
5543 yj = (xv(2,j)-torby(ie))/1d3
5544 ypj = (yv(2,j)-torbyp(ie))/1d3
5545 pj = ejv(j)/1.e3
5546 if(firstrun) then
5547 if (iturn.eq.1.and.j.eq.1) then
5548 sum_ax(ie)=0d0
5549 sum_ay(ie)=0d0
5550 endif
5551 endif
5552 gammax = (1d0 + talphax(ie)**2)/tbetax(ie)
5553 gammay = (1d0 + talphay(ie)**2)/tbetay(ie)
5554 if (part_abs(j).eq.0) then
5555
5556 xdebug(ie)=xj
5557 xpdebug(ie)=xpj
5558 ydebug(ie)=yj
5559 ypdebug(ie)=ypj
5560 xdebugN(ie)= xdebug(ie)/sqrt(myemitx0*
5561 & tbetax(ie))
5562 xpdebugN(ie)=(xdebug(ie)*talphax(ie)+
5563 & xpdebug(ie)*tbetax(ie))
5564 & /sqrt(myemitx0*tbetax(ie))
5565 ydebugN(ie)=ydebug(ie)/sqrt(myemity0*
5566 & tbetay(ie))
5567 ypdebugN(ie)=(ydebug(ie)*talphay(ie)+
5568 & ypdebug(ie)*tbetay(ie))
5569 & /sqrt(myemity0*tbetay(ie))
5570
5571 nspx = sqrt( &
5572 & abs( gammax*(xj)**2 + &
5573 & 2d0*talphax(ie)*xj*xpj + &
5574 & tbetax(ie)*xpj**2 )/myemitx0 &
5575 & )
5576 nspy = sqrt( &
5577 & abs( gammay*(yj)**2 + &
5578 & 2d0*talphay(ie)*yj*ypj + &
5579 & tbetay(ie)*ypj**2 )/myemity0
5580 & )
5581 sum_ax(ie) = sum_ax(ie) + nspx
5582 sqsum_ax(ie) = sqsum_ax(ie) + nspx**2
5583 sum_ay(ie) = sum_ay(ie) + nspy
5584 sqsum_ay(ie) = sqsum_ay(ie) + nspy**2
5585 nampl(ie) = nampl(ie) + 1
5586 else
5587 nspx = 0d0
5588 nspy = 0d0
5589 endif
5590 sampl(ie) = totals
5591 ename(ie) = bez(myix)(1:16)
5592 23 continue
5593 endif
5594 goto 650
5595 !GRD END OF THE CHANGES FOR COLLIMATION STUDIES, BACK TO NORMAL SIXTRACK STUFF
5596 30 do 40 j=1,napx
5597 ejf0v(j)=ejfv(j)
5598 if(abs(dppoff).gt.pieni) sigmv(j)=sigmv(j)-sigmoff(i)
5599 if(kz(ix).eq.12) then
5600 ejv(j)=ejv(j)+ed(ix)*sin(hsyc(ix)*sigmv(j)+ &
5601 &phasc(ix))
5602 else
5603 ejv(j)=ejv(j)+hsy(1)*sin(hsy(3)*sigmv(j))
5604 endif
5605 ejfv(j)=sqrt(ejv(j)*ejv(j)-pma*pma)
5606 rvv(j)=(ejv(j)*e0f)/(e0*ejfv(j))
5607 dpsv(j)=(ejfv(j)-e0f)/e0f
5608 oidpsv(j)=one/(one+dpsv(j))
5609 dpsv1(j)=dpsv(j)*c1e3*oidpsv(j)
5610 yv(1,j)=ejf0v(j)/ejfv(j)*yv(1,j)
5611 yv(2,j)=ejf0v(j)/ejfv(j)*yv(2,j)
5612 40 continue
5613 if(n.eq.1) write(98,'(1p,6(2x,e25.18))') &
5614 &(xv(1,j),yv(1,j),xv(2,j),yv(2,j),sigmv(j),dpsv(j),j=1,napx)
5615 goto 640
5616 !--HORIZONTAL DIPOLE
5617 50 do 60 j=1,napx
5618 yv(1,j)=yv(1,j)+strackc(i)*oidpsv(j)
5619 yv(2,j)=yv(2,j)+stracks(i)*oidpsv(j)
5620 60 continue
5621 goto 640
5622 !--NORMAL QUADRUPOLE
5623 70 do 80 j=1,napx
5624 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
5625 &(xv(2,j)-zsiv(1,i))*tilts(i)
5626 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
5627 &(xv(2,j)-zsiv(1,i))*tiltc(i)
5628 crkve=xlv(j)
5629 cikve=zlv(j)
5630 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
5631 &stracks(i)*cikve)
5632 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
5633 &stracks(i)*crkve)
5634 80 continue
5635 goto 640
5636 !--NORMAL SEXTUPOLE
5637 90 do 100 j=1,napx
5638 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
5639 &(xv(2,j)-zsiv(1,i))*tilts(i)
5640 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
5641 &(xv(2,j)-zsiv(1,i))*tiltc(i)
5642 crkve=xlv(j)
5643 cikve=zlv(j)
5644 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5645 cikve=crkve*zlv(j)+cikve*xlv(j)
5646 crkve=crkveuk
5647 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
5648 &stracks(i)*cikve)
5649 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
5650 &stracks(i)*crkve)
5651 100 continue
5652 goto 640
5653 !--NORMAL OCTUPOLE
5654 110 do 120 j=1,napx
5655 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
5656 &(xv(2,j)-zsiv(1,i))*tilts(i)
5657 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
5658 &(xv(2,j)-zsiv(1,i))*tiltc(i)
5659 crkve=xlv(j)
5660 cikve=zlv(j)
5661 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5662 cikve=crkve*zlv(j)+cikve*xlv(j)
5663 crkve=crkveuk
5664 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5665 cikve=crkve*zlv(j)+cikve*xlv(j)
5666 crkve=crkveuk
5667 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
5668 &stracks(i)*cikve)
5669 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
5670 &stracks(i)*crkve)
5671 120 continue
5672 goto 640
5673 !--NORMAL DECAPOLE
5674 130 do 140 j=1,napx
5675 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
5676 &(xv(2,j)-zsiv(1,i))*tilts(i)
5677 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
5678 &(xv(2,j)-zsiv(1,i))*tiltc(i)
5679 crkve=xlv(j)
5680 cikve=zlv(j)
5681 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5682 cikve=crkve*zlv(j)+cikve*xlv(j)
5683 crkve=crkveuk
5684 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5685 cikve=crkve*zlv(j)+cikve*xlv(j)
5686 crkve=crkveuk
5687 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5688 cikve=crkve*zlv(j)+cikve*xlv(j)
5689 crkve=crkveuk
5690 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
5691 &stracks(i)*cikve)
5692 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
5693 &stracks(i)*crkve)
5694 140 continue
5695 goto 640
5696 !--NORMAL DODECAPOLE
5697 150 do 160 j=1,napx
5698 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
5699 &(xv(2,j)-zsiv(1,i))*tilts(i)
5700 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
5701 &(xv(2,j)-zsiv(1,i))*tiltc(i)
5702 crkve=xlv(j)
5703 cikve=zlv(j)
5704 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5705 cikve=crkve*zlv(j)+cikve*xlv(j)
5706 crkve=crkveuk
5707 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5708 cikve=crkve*zlv(j)+cikve*xlv(j)
5709 crkve=crkveuk
5710 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5711 cikve=crkve*zlv(j)+cikve*xlv(j)
5712 crkve=crkveuk
5713 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5714 cikve=crkve*zlv(j)+cikve*xlv(j)
5715 crkve=crkveuk
5716 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
5717 &stracks(i)*cikve)
5718 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
5719 &stracks(i)*crkve)
5720 160 continue
5721 goto 640
5722 !--NORMAL 14-POLE
5723 170 do 180 j=1,napx
5724 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
5725 &(xv(2,j)-zsiv(1,i))*tilts(i)
5726 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
5727 &(xv(2,j)-zsiv(1,i))*tiltc(i)
5728 crkve=xlv(j)
5729 cikve=zlv(j)
5730 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5731 cikve=crkve*zlv(j)+cikve*xlv(j)
5732 crkve=crkveuk
5733 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5734 cikve=crkve*zlv(j)+cikve*xlv(j)
5735 crkve=crkveuk
5736 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5737 cikve=crkve*zlv(j)+cikve*xlv(j)
5738 crkve=crkveuk
5739 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5740 cikve=crkve*zlv(j)+cikve*xlv(j)
5741 crkve=crkveuk
5742 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5743 cikve=crkve*zlv(j)+cikve*xlv(j)
5744 crkve=crkveuk
5745 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
5746 &stracks(i)*cikve)
5747 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
5748 &stracks(i)*crkve)
5749 180 continue
5750 goto 640
5751 !--NORMAL 16-POLE
5752 190 do 200 j=1,napx
5753 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
5754 &(xv(2,j)-zsiv(1,i))*tilts(i)
5755 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
5756 &(xv(2,j)-zsiv(1,i))*tiltc(i)
5757 crkve=xlv(j)
5758 cikve=zlv(j)
5759 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5760 cikve=crkve*zlv(j)+cikve*xlv(j)
5761 crkve=crkveuk
5762 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5763 cikve=crkve*zlv(j)+cikve*xlv(j)
5764 crkve=crkveuk
5765 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5766 cikve=crkve*zlv(j)+cikve*xlv(j)
5767 crkve=crkveuk
5768 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5769 cikve=crkve*zlv(j)+cikve*xlv(j)
5770 crkve=crkveuk
5771 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5772 cikve=crkve*zlv(j)+cikve*xlv(j)
5773 crkve=crkveuk
5774 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5775 cikve=crkve*zlv(j)+cikve*xlv(j)
5776 crkve=crkveuk
5777 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
5778 &stracks(i)*cikve)
5779 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
5780 &stracks(i)*crkve)
5781 200 continue
5782 goto 640
5783 !--NORMAL 18-POLE
5784 210 do 220 j=1,napx
5785 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
5786 &(xv(2,j)-zsiv(1,i))*tilts(i)
5787 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
5788 &(xv(2,j)-zsiv(1,i))*tiltc(i)
5789 crkve=xlv(j)
5790 cikve=zlv(j)
5791 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5792 cikve=crkve*zlv(j)+cikve*xlv(j)
5793 crkve=crkveuk
5794 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5795 cikve=crkve*zlv(j)+cikve*xlv(j)
5796 crkve=crkveuk
5797 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5798 cikve=crkve*zlv(j)+cikve*xlv(j)
5799 crkve=crkveuk
5800 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5801 cikve=crkve*zlv(j)+cikve*xlv(j)
5802 crkve=crkveuk
5803 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5804 cikve=crkve*zlv(j)+cikve*xlv(j)
5805 crkve=crkveuk
5806 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5807 cikve=crkve*zlv(j)+cikve*xlv(j)
5808 crkve=crkveuk
5809 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5810 cikve=crkve*zlv(j)+cikve*xlv(j)
5811 crkve=crkveuk
5812 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
5813 &stracks(i)*cikve)
5814 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
5815 &stracks(i)*crkve)
5816 220 continue
5817 goto 640
5818 !--NORMAL 20-POLE
5819 230 do 240 j=1,napx
5820 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
5821 &(xv(2,j)-zsiv(1,i))*tilts(i)
5822 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
5823 &(xv(2,j)-zsiv(1,i))*tiltc(i)
5824 crkve=xlv(j)
5825 cikve=zlv(j)
5826 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5827 cikve=crkve*zlv(j)+cikve*xlv(j)
5828 crkve=crkveuk
5829 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5830 cikve=crkve*zlv(j)+cikve*xlv(j)
5831 crkve=crkveuk
5832 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5833 cikve=crkve*zlv(j)+cikve*xlv(j)
5834 crkve=crkveuk
5835 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5836 cikve=crkve*zlv(j)+cikve*xlv(j)
5837 crkve=crkveuk
5838 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5839 cikve=crkve*zlv(j)+cikve*xlv(j)
5840 crkve=crkveuk
5841 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5842 cikve=crkve*zlv(j)+cikve*xlv(j)
5843 crkve=crkveuk
5844 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5845 cikve=crkve*zlv(j)+cikve*xlv(j)
5846 crkve=crkveuk
5847 crkveuk=crkve*xlv(j)-cikve*zlv(j)
5848 cikve=crkve*zlv(j)+cikve*xlv(j)
5849 crkve=crkveuk
5850 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
5851 &stracks(i)*cikve)
5852 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
5853 &stracks(i)*crkve)
5854 240 continue
5855 goto 640
5856 250 continue
5857 do 260 j=1,napx
5858 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
5859 &(xv(2,j)-zsiv(1,i))*tilts(i)
5860 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
5861 &(xv(2,j)-zsiv(1,i))*tiltc(i)
5862 yv(1,j)=yv(1,j)-(strack(i)*xlvj*oidpsv(j) &
5863 &+dpsv1(j))*dki(ix,1)*tiltc(i) &
5864 &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
5865 yv(2,j)=yv(2,j)-(strack(i)*xlvj*oidpsv(j) &
5866 &+dpsv1(j))*dki(ix,1)*tilts(i) &
5867 &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
5868 sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
5869 260 continue
5870 goto 640
5871 270 continue
5872 do 280 j=1,napx
5873 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
5874 &(xv(2,j)-zsiv(1,i))*tilts(i)
5875 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
5876 &(xv(2,j)-zsiv(1,i))*tiltc(i)
5877 yv(1,j)=yv(1,j)-(strack(i)*xlvj*oidpsv(j) &
5878 &+dpsv1(j))*dki(ix,1)*tiltc(i) &
5879 &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
5880 yv(2,j)=yv(2,j)-(strack(i)*xlvj*oidpsv(j) &
5881 &+dpsv1(j))*dki(ix,1)*tilts(i) &
5882 &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
5883 sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
5884 280 continue
5885 goto 410
5886 290 continue
5887 do 300 j=1,napx
5888 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
5889 &(xv(2,j)-zsiv(1,i))*tilts(i)
5890 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
5891 &(xv(2,j)-zsiv(1,i))*tiltc(i)
5892 yv(1,j)=yv(1,j)-strackc(i)*dpsv1(j) &
5893 &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
5894 yv(2,j)=yv(2,j)-stracks(i)*dpsv1(j) &
5895 &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
5896 sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
5897 300 continue
5898 goto 640
5899 310 continue
5900 do 320 j=1,napx
5901 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
5902 &(xv(2,j)-zsiv(1,i))*tilts(i)
5903 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
5904 &(xv(2,j)-zsiv(1,i))*tiltc(i)
5905 yv(1,j)=yv(1,j)-strackc(i)*dpsv1(j) &
5906 &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
5907 yv(2,j)=yv(2,j)-stracks(i)*dpsv1(j) &
5908 &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
5909 sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
5910 320 continue
5911 goto 410
5912 330 continue
5913 do 340 j=1,napx
5914 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
5915 &(xv(2,j)-zsiv(1,i))*tilts(i)
5916 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
5917 &(xv(2,j)-zsiv(1,i))*tiltc(i)
5918 yv(1,j)=yv(1,j)+(strack(i)*zlvj*oidpsv(j) &
5919 &-dpsv1(j))*dki(ix,2)*tilts(i) &
5920 &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
5921 yv(2,j)=yv(2,j)-(strack(i)*zlvj*oidpsv(j) &
5922 &-dpsv1(j))*dki(ix,2)*tiltc(i) &
5923 &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
5924 sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
5925 340 continue
5926 goto 640
5927 350 continue
5928 do 360 j=1,napx
5929 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
5930 &(xv(2,j)-zsiv(1,i))*tilts(i)
5931 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
5932 &(xv(2,j)-zsiv(1,i))*tiltc(i)
5933 yv(1,j)=yv(1,j)+(strack(i)*zlvj*oidpsv(j) &
5934 &-dpsv1(j))*dki(ix,2)*tilts(i) &
5935 &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
5936 yv(2,j)=yv(2,j)-(strack(i)*zlvj*oidpsv(j) &
5937 &-dpsv1(j))*dki(ix,2)*tiltc(i) &
5938 &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
5939 sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
5940 360 continue
5941 goto 410
5942 370 continue
5943 do 380 j=1,napx
5944 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
5945 &(xv(2,j)-zsiv(1,i))*tilts(i)
5946 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
5947 &(xv(2,j)-zsiv(1,i))*tiltc(i)
5948 yv(1,j)=yv(1,j)-stracks(i)*dpsv1(j) &
5949 &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
5950 yv(2,j)=yv(2,j)+strackc(i)*dpsv1(j) &
5951 &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
5952 sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
5953 380 continue
5954 goto 640
5955 390 continue
5956 do 400 j=1,napx
5957 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
5958 &(xv(2,j)-zsiv(1,i))*tilts(i)
5959 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
5960 &(xv(2,j)-zsiv(1,i))*tiltc(i)
5961 yv(1,j)=yv(1,j)-stracks(i)*dpsv1(j) &
5962 &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
5963 yv(2,j)=yv(2,j)+strackc(i)*dpsv1(j) &
5964 &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
5965 sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
5966 400 continue
5967 410 r0=ek(ix)
5968 nmz=nmu(ix)
5969 if(nmz.ge.2) then
5970 do 430 j=1,napx
5971 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
5972 &(xv(2,j)-zsiv(1,i))*tilts(i)
5973 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
5974 &(xv(2,j)-zsiv(1,i))*tiltc(i)
5975 yv1j=bbiv(1,1,i)+bbiv(2,1,i)*xlvj+aaiv(2,1,i)*zlvj
5976 yv2j=aaiv(1,1,i)-bbiv(2,1,i)*zlvj+aaiv(2,1,i)*xlvj
5977 crkve=xlvj
5978 cikve=zlvj
5979 do 420 k=3,nmz
5980 crkveuk=crkve*xlvj-cikve*zlvj
5981 cikve=crkve*zlvj+cikve*xlvj
5982 crkve=crkveuk
5983 yv1j=yv1j+bbiv(k,1,i)*crkve+aaiv(k,1,i)*cikve
5984 yv2j=yv2j-bbiv(k,1,i)*cikve+aaiv(k,1,i)*crkve
5985 420 continue
5986 yv(1,j)=yv(1,j)+(tiltc(i)*yv1j-tilts(i)*yv2j)*oidpsv(j)
5987 yv(2,j)=yv(2,j)+(tiltc(i)*yv2j+tilts(i)*yv1j)*oidpsv(j)
5988 430 continue
5989 else
5990 do 435 j=1,napx
5991 yv(1,j)=yv(1,j)+(tiltc(i)*bbiv(1,1,i)- &
5992 &tilts(i)*aaiv(1,1,i))*oidpsv(j)
5993 yv(2,j)=yv(2,j)+(tiltc(i)*aaiv(1,1,i)+ &
5994 &tilts(i)*bbiv(1,1,i))*oidpsv(j)
5995 435 continue
5996 endif
5997 goto 640
5998 !--SKEW ELEMENTS
5999 !--VERTICAL DIPOLE
6000 440 do 450 j=1,napx
6001 yv(1,j)=yv(1,j)-stracks(i)*oidpsv(j)
6002 yv(2,j)=yv(2,j)+strackc(i)*oidpsv(j)
6003 450 continue
6004 goto 640
6005 !--SKEW QUADRUPOLE
6006 460 do 470 j=1,napx
6007 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
6008 &(xv(2,j)-zsiv(1,i))*tilts(i)
6009 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
6010 &(xv(2,j)-zsiv(1,i))*tiltc(i)
6011 crkve=xlv(j)
6012 cikve=zlv(j)
6013 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
6014 &stracks(i)*crkve)
6015 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
6016 &stracks(i)*cikve)
6017 470 continue
6018 goto 640
6019 !--SKEW SEXTUPOLE
6020 480 do 490 j=1,napx
6021 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
6022 &(xv(2,j)-zsiv(1,i))*tilts(i)
6023 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
6024 &(xv(2,j)-zsiv(1,i))*tiltc(i)
6025 crkve=xlv(j)
6026 cikve=zlv(j)
6027 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6028 cikve=crkve*zlv(j)+cikve*xlv(j)
6029 crkve=crkveuk
6030 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
6031 &stracks(i)*crkve)
6032 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
6033 &stracks(i)*cikve)
6034 490 continue
6035 goto 640
6036 !--SKEW OCTUPOLE
6037 500 do 510 j=1,napx
6038 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
6039 &(xv(2,j)-zsiv(1,i))*tilts(i)
6040 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
6041 &(xv(2,j)-zsiv(1,i))*tiltc(i)
6042 crkve=xlv(j)
6043 cikve=zlv(j)
6044 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6045 cikve=crkve*zlv(j)+cikve*xlv(j)
6046 crkve=crkveuk
6047 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6048 cikve=crkve*zlv(j)+cikve*xlv(j)
6049 crkve=crkveuk
6050 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
6051 &stracks(i)*crkve)
6052 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
6053 &stracks(i)*cikve)
6054 510 continue
6055 goto 640
6056 !--SKEW DECAPOLE
6057 520 do 530 j=1,napx
6058 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
6059 &(xv(2,j)-zsiv(1,i))*tilts(i)
6060 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
6061 &(xv(2,j)-zsiv(1,i))*tiltc(i)
6062 crkve=xlv(j)
6063 cikve=zlv(j)
6064 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6065 cikve=crkve*zlv(j)+cikve*xlv(j)
6066 crkve=crkveuk
6067 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6068 cikve=crkve*zlv(j)+cikve*xlv(j)
6069 crkve=crkveuk
6070 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6071 cikve=crkve*zlv(j)+cikve*xlv(j)
6072 crkve=crkveuk
6073 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
6074 &stracks(i)*crkve)
6075 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
6076 &stracks(i)*cikve)
6077 530 continue
6078 goto 640
6079 !--SKEW DODECAPOLE
6080 540 do 550 j=1,napx
6081 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
6082 &(xv(2,j)-zsiv(1,i))*tilts(i)
6083 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
6084 &(xv(2,j)-zsiv(1,i))*tiltc(i)
6085 crkve=xlv(j)
6086 cikve=zlv(j)
6087 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6088 cikve=crkve*zlv(j)+cikve*xlv(j)
6089 crkve=crkveuk
6090 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6091 cikve=crkve*zlv(j)+cikve*xlv(j)
6092 crkve=crkveuk
6093 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6094 cikve=crkve*zlv(j)+cikve*xlv(j)
6095 crkve=crkveuk
6096 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6097 cikve=crkve*zlv(j)+cikve*xlv(j)
6098 crkve=crkveuk
6099 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
6100 &stracks(i)*crkve)
6101 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
6102 &stracks(i)*cikve)
6103 550 continue
6104 goto 640
6105 !--SKEW 14-POLE
6106 560 do 570 j=1,napx
6107 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
6108 &(xv(2,j)-zsiv(1,i))*tilts(i)
6109 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
6110 &(xv(2,j)-zsiv(1,i))*tiltc(i)
6111 crkve=xlv(j)
6112 cikve=zlv(j)
6113 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6114 cikve=crkve*zlv(j)+cikve*xlv(j)
6115 crkve=crkveuk
6116 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6117 cikve=crkve*zlv(j)+cikve*xlv(j)
6118 crkve=crkveuk
6119 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6120 cikve=crkve*zlv(j)+cikve*xlv(j)
6121 crkve=crkveuk
6122 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6123 cikve=crkve*zlv(j)+cikve*xlv(j)
6124 crkve=crkveuk
6125 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6126 cikve=crkve*zlv(j)+cikve*xlv(j)
6127 crkve=crkveuk
6128 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
6129 &stracks(i)*crkve)
6130 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
6131 &stracks(i)*cikve)
6132 570 continue
6133 goto 640
6134 !--SKEW 16-POLE
6135 580 do 590 j=1,napx
6136 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
6137 &(xv(2,j)-zsiv(1,i))*tilts(i)
6138 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
6139 &(xv(2,j)-zsiv(1,i))*tiltc(i)
6140 crkve=xlv(j)
6141 cikve=zlv(j)
6142 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6143 cikve=crkve*zlv(j)+cikve*xlv(j)
6144 crkve=crkveuk
6145 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6146 cikve=crkve*zlv(j)+cikve*xlv(j)
6147 crkve=crkveuk
6148 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6149 cikve=crkve*zlv(j)+cikve*xlv(j)
6150 crkve=crkveuk
6151 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6152 cikve=crkve*zlv(j)+cikve*xlv(j)
6153 crkve=crkveuk
6154 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6155 cikve=crkve*zlv(j)+cikve*xlv(j)
6156 crkve=crkveuk
6157 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6158 cikve=crkve*zlv(j)+cikve*xlv(j)
6159 crkve=crkveuk
6160 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
6161 &stracks(i)*crkve)
6162 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
6163 &stracks(i)*cikve)
6164 590 continue
6165 goto 640
6166 !--SKEW 18-POLE
6167 600 do 610 j=1,napx
6168 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
6169 &(xv(2,j)-zsiv(1,i))*tilts(i)
6170 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
6171 &(xv(2,j)-zsiv(1,i))*tiltc(i)
6172 crkve=xlv(j)
6173 cikve=zlv(j)
6174 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6175 cikve=crkve*zlv(j)+cikve*xlv(j)
6176 crkve=crkveuk
6177 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6178 cikve=crkve*zlv(j)+cikve*xlv(j)
6179 crkve=crkveuk
6180 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6181 cikve=crkve*zlv(j)+cikve*xlv(j)
6182 crkve=crkveuk
6183 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6184 cikve=crkve*zlv(j)+cikve*xlv(j)
6185 crkve=crkveuk
6186 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6187 cikve=crkve*zlv(j)+cikve*xlv(j)
6188 crkve=crkveuk
6189 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6190 cikve=crkve*zlv(j)+cikve*xlv(j)
6191 crkve=crkveuk
6192 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6193 cikve=crkve*zlv(j)+cikve*xlv(j)
6194 crkve=crkveuk
6195 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
6196 &stracks(i)*crkve)
6197 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
6198 &stracks(i)*cikve)
6199 610 continue
6200 goto 640
6201 !--SKEW 20-POLE
6202 620 do 630 j=1,napx
6203 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
6204 &(xv(2,j)-zsiv(1,i))*tilts(i)
6205 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
6206 &(xv(2,j)-zsiv(1,i))*tiltc(i)
6207 crkve=xlv(j)
6208 cikve=zlv(j)
6209 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6210 cikve=crkve*zlv(j)+cikve*xlv(j)
6211 crkve=crkveuk
6212 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6213 cikve=crkve*zlv(j)+cikve*xlv(j)
6214 crkve=crkveuk
6215 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6216 cikve=crkve*zlv(j)+cikve*xlv(j)
6217 crkve=crkveuk
6218 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6219 cikve=crkve*zlv(j)+cikve*xlv(j)
6220 crkve=crkveuk
6221 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6222 cikve=crkve*zlv(j)+cikve*xlv(j)
6223 crkve=crkveuk
6224 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6225 cikve=crkve*zlv(j)+cikve*xlv(j)
6226 crkve=crkveuk
6227 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6228 cikve=crkve*zlv(j)+cikve*xlv(j)
6229 crkve=crkveuk
6230 crkveuk=crkve*xlv(j)-cikve*zlv(j)
6231 cikve=crkve*zlv(j)+cikve*xlv(j)
6232 crkve=crkveuk
6233 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
6234 &stracks(i)*crkve)
6235 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
6236 &stracks(i)*cikve)
6237 630 continue
6238 goto 640
6239 680 continue
6240 do 690 j=1,napx
6241 if(ibbc.eq.0) then
6242 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
6243 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
6244 else
6245 crkveb(j)= &
6246 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
6247 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
6248 cikveb(j)= &
6249 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
6250 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
6251 endif
6252 rho2b(j)=crkveb(j)*crkveb(j)+cikveb(j)*cikveb(j)
6253 if(rho2b(j).le.pieni) &
6254 &goto 690
6255 tkb(j)=rho2b(j)/(two*sigman2(1,imbb(i)))
6256 if(ibbc.eq.0) then
6257 yv(1,j)=yv(1,j)+oidpsv(j)*(strack(i)*crkveb(j)/rho2b(j)* &
6258 &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))
6259 yv(2,j)=yv(2,j)+oidpsv(j)*(strack(i)*cikveb(j)/rho2b(j)* &
6260 &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))
6261 else
6262 cccc=(strack(i)*crkveb(j)/rho2b(j)* &
6263 &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))*bbcu(imbb(i),11)- &
6264 &(strack(i)*cikveb(j)/rho2b(j)* &
6265 &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
6266 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
6267 cccc=(strack(i)*crkveb(j)/rho2b(j)* &
6268 &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))*bbcu(imbb(i),12)+ &
6269 &(strack(i)*cikveb(j)/rho2b(j)* &
6270 &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
6271 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
6272 endif
6273 690 continue
6274 goto 640
6275 700 continue
6276 if(ibtyp.eq.0) then
6277 do j=1,napx
6278 r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
6279 rb(j)=sqrt(r2b(j))
6280 rkb(j)=strack(i)*pisqrt/rb(j)
6281 if(ibbc.eq.0) then
6282 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
6283 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
6284 else
6285 crkveb(j)= &
6286 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
6287 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
6288 cikveb(j)= &
6289 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
6290 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
6291 endif
6292 xrb(j)=abs(crkveb(j))/rb(j)
6293 zrb(j)=abs(cikveb(j))/rb(j)
6294 call errf(xrb(j),zrb(j),crxb(j),crzb(j))
6295 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
6296 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
6297 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
6298 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
6299 call errf(xbb(j),zbb(j),cbxb(j),cbzb(j))
6300 if(ibbc.eq.0) then
6301 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
6302 &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
6303 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
6304 &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
6305 else
6306 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
6307 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
6308 &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
6309 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
6310 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
6311 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
6312 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
6313 &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
6314 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
6315 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
6316 endif
6317 enddo
6318 else if(ibtyp.eq.1) then
6319 do j=1,napx
6320 r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
6321 rb(j)=sqrt(r2b(j))
6322 rkb(j)=strack(i)*pisqrt/rb(j)
6323 if(ibbc.eq.0) then
6324 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
6325 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
6326 else
6327 crkveb(j)= &
6328 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
6329 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
6330 cikveb(j)= &
6331 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
6332 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
6333 endif
6334 xrb(j)=abs(crkveb(j))/rb(j)
6335 zrb(j)=abs(cikveb(j))/rb(j)
6336 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
6337 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
6338 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
6339 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
6340 enddo
6341 call wzsubv(napx,xrb(1),zrb(1),crxb(1),crzb(1))
6342 call wzsubv(napx,xbb(1),zbb(1),cbxb(1),cbzb(1))
6343 do j=1,napx
6344 if(ibbc.eq.0) then
6345 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
6346 &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
6347 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
6348 &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
6349 else
6350 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
6351 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
6352 &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
6353 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
6354 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
6355 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
6356 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
6357 &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
6358 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
6359 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
6360 endif
6361 enddo
6362 endif
6363 goto 640
6364 720 continue
6365 if(ibtyp.eq.0) then
6366 do j=1,napx
6367 r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
6368 rb(j)=sqrt(r2b(j))
6369 rkb(j)=strack(i)*pisqrt/rb(j)
6370 if(ibbc.eq.0) then
6371 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
6372 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
6373 else
6374 crkveb(j)= &
6375 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
6376 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
6377 cikveb(j)= &
6378 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
6379 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
6380 endif
6381 xrb(j)=abs(crkveb(j))/rb(j)
6382 zrb(j)=abs(cikveb(j))/rb(j)
6383 call errf(zrb(j),xrb(j),crzb(j),crxb(j))
6384 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
6385 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
6386 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
6387 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
6388 call errf(zbb(j),xbb(j),cbzb(j),cbxb(j))
6389 if(ibbc.eq.0) then
6390 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
6391 &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
6392 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
6393 &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
6394 else
6395 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
6396 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
6397 &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
6398 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
6399 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
6400 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
6401 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
6402 &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
6403 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
6404 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
6405 endif
6406 enddo
6407 else if(ibtyp.eq.1) then
6408 do j=1,napx
6409 r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
6410 rb(j)=sqrt(r2b(j))
6411 rkb(j)=strack(i)*pisqrt/rb(j)
6412 if(ibbc.eq.0) then
6413 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
6414 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
6415 else
6416 crkveb(j)= &
6417 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
6418 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
6419 cikveb(j)= &
6420 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
6421 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
6422 endif
6423 xrb(j)=abs(crkveb(j))/rb(j)
6424 zrb(j)=abs(cikveb(j))/rb(j)
6425 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
6426 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
6427 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
6428 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
6429 enddo
6430 call wzsubv(napx,zrb(1),xrb(1),crzb(1),crxb(1))
6431 call wzsubv(napx,zbb(1),xbb(1),cbzb(1),cbxb(1))
6432 do j=1,napx
6433 if(ibbc.eq.0) then
6434 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
6435 &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
6436 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
6437 &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
6438 else
6439 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
6440 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
6441 &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
6442 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
6443 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
6444 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
6445 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
6446 &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
6447 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
6448 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
6449 endif
6450 enddo
6451 endif
6452 goto 640
6453 730 continue
6454 !--Hirata's 6D beam-beam kick
6455 do j=1,napx
6456 track6d(1,j)=(xv(1,j)+ed(ix)-clobeam(1,imbb(i)))*c1m3
6457 track6d(2,j)=(yv(1,j)/oidpsv(j)-clobeam(4,imbb(i)))*c1m3
6458 track6d(3,j)=(xv(2,j)+ek(ix)-clobeam(2,imbb(i)))*c1m3
6459 track6d(4,j)=(yv(2,j)/oidpsv(j)-clobeam(5,imbb(i)))*c1m3
6460 track6d(5,j)=(sigmv(j)-clobeam(3,imbb(i)))*c1m3
6461 track6d(6,j)=dpsv(j)-clobeam(6,imbb(i))
6462 enddo
6463 call beamint(napx,track6d,parbe,sigz,bbcu,imbb(i),ix,ibtyp, &
6464 &ibbc)
6465 do j=1,napx
6466 xv(1,j)=track6d(1,j)*c1e3+clobeam(1,imbb(i))- &
6467 &beamoff(1,imbb(i))
6468 xv(2,j)=track6d(3,j)*c1e3+clobeam(2,imbb(i))- &
6469 &beamoff(2,imbb(i))
6470 dpsv(j)=track6d(6,j)+clobeam(6,imbb(i))-beamoff(6,imbb(i))
6471 oidpsv(j)=one/(one+dpsv(j))
6472 yv(1,j)=(track6d(2,j)*c1e3+clobeam(4,imbb(i))- &
6473 &beamoff(4,imbb(i)))*oidpsv(j)
6474 yv(2,j)=(track6d(4,j)*c1e3+clobeam(5,imbb(i))- &
6475 &beamoff(5,imbb(i)))*oidpsv(j)
6476 ejfv(j)=dpsv(j)*e0f+e0f
6477 ejv(j)=sqrt(ejfv(j)*ejfv(j)+pma*pma)
6478 rvv(j)=(ejv(j)*e0f)/(e0*ejfv(j))
6479 if(ithick.eq.1) call envarsv(dpsv,oidpsv,rvv,ekv)
6480 enddo
6481 goto 640
6482 740 continue
6483 irrtr=imtr(ix)
6484 do j=1,napx
6485 sigmv(j)=sigmv(j)+cotr(irrtr,5)+rrtr(irrtr,5,1)*xv(1,j)+ &
6486 &rrtr(irrtr,5,2)*yv(1,j)+rrtr(irrtr,5,3)*xv(2,j)+ &
6487 &rrtr(irrtr,5,4)*yv(2,j)
6488 pux=xv(1,j)
6489 dpsv3(j)=dpsv(j)*c1e3
6490 xv(1,j)=cotr(irrtr,1)+rrtr(irrtr,1,1)*pux+ &
6491 &rrtr(irrtr,1,2)*yv(1,j)+idz(1)*dpsv3(j)*rrtr(irrtr,1,6)
6492 yv(1,j)=cotr(irrtr,2)+rrtr(irrtr,2,1)*pux+ &
6493 &rrtr(irrtr,2,2)*yv(1,j)+idz(1)*dpsv3(j)*rrtr(irrtr,2,6)
6494 pux=xv(2,j)
6495 xv(2,j)=cotr(irrtr,3)+rrtr(irrtr,3,3)*pux+ &
6496 &rrtr(irrtr,3,4)*yv(2,j)+idz(2)*dpsv3(j)*rrtr(irrtr,3,6)
6497 yv(2,j)=cotr(irrtr,4)+rrtr(irrtr,4,3)*pux+ &
6498 &rrtr(irrtr,4,4)*yv(2,j)+idz(2)*dpsv3(j)*rrtr(irrtr,4,6)
6499 enddo
6500
6501 !----------------------------------------------------------------------
6502
6503 ! Wire.
6504
6505 goto 640
6506 745 continue
6507 xory=1
6508 nfree=nturn1(ix)
6509 if(n.gt.nfree) then
6510 nac=n-nfree
6511 pi=4d0*atan(1d0)
6512 !---------ACdipAmp input in Tesla*meter converted to KeV/c
6513 !---------ejfv(j) should be in MeV/c --> ACdipAmp/ejfv(j) is in mrad
6514 acdipamp=ed(ix)*clight*1.0d-3
6515 !---------Qd input in tune units
6516 qd=ek(ix)
6517 !---------ACphase input in radians
6518 acphase=acdipph(ix)
6519 nramp1=nturn2(ix)
6520 nplato=nturn3(ix)
6521 nramp2=nturn4(ix)
6522 do j=1,napx
6523 if (xory.eq.1) then
6524 acdipamp2=acdipamp*tilts(i)
6525 acdipamp1=acdipamp*tiltc(i)
6526 else
6527 acdipamp2=acdipamp*tiltc(i)
6528 acdipamp1=-acdipamp*tilts(i)
6529 endif
6530 if(nramp1.gt.nac) then
6531 yv(1,j)=yv(1,j)+acdipamp1* &
6532 &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
6533 yv(2,j)=yv(2,j)+acdipamp2* &
6534 &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
6535 endif
6536 if(nac.ge.nramp1.and.(nramp1+nplato).gt.nac) then
6537 yv(1,j)=yv(1,j)+acdipamp1* &
6538 &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
6539 yv(2,j)=yv(2,j)+acdipamp2* &
6540 &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
6541 endif
6542 if(nac.ge.(nramp1+nplato).and.(nramp2+nramp1+nplato).gt. &
6543 &nac)then
6544 yv(1,j)=yv(1,j)+acdipamp1*sin(2d0*pi*qd*nac+acphase)* &
6545 &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
6546 yv(2,j)=yv(2,j)+acdipamp2*sin(2d0*pi*qd*nac+acphase)* &
6547 &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
6548 endif
6549 enddo
6550 endif
6551 goto 640
6552 746 continue
6553 xory=2
6554 nfree=nturn1(ix)
6555 if(n.gt.nfree) then
6556 nac=n-nfree
6557 pi=4d0*atan(1d0)
6558 !---------ACdipAmp input in Tesla*meter converted to KeV/c
6559 !---------ejfv(j) should be in MeV/c --> ACdipAmp/ejfv(j) is in mrad
6560 acdipamp=ed(ix)*clight*1.0d-3
6561 !---------Qd input in tune units
6562 qd=ek(ix)
6563 !---------ACphase input in radians
6564 acphase=acdipph(ix)
6565 nramp1=nturn2(ix)
6566 nplato=nturn3(ix)
6567 nramp2=nturn4(ix)
6568 do j=1,napx
6569 if (xory.eq.1) then
6570 acdipamp2=acdipamp*tilts(i)
6571 acdipamp1=acdipamp*tiltc(i)
6572 else
6573 acdipamp2=acdipamp*tiltc(i)
6574 acdipamp1=-acdipamp*tilts(i)
6575 endif
6576 if(nramp1.gt.nac) then
6577 yv(1,j)=yv(1,j)+acdipamp1* &
6578 &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
6579 yv(2,j)=yv(2,j)+acdipamp2* &
6580 &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
6581 endif
6582 if(nac.ge.nramp1.and.(nramp1+nplato).gt.nac) then
6583 yv(1,j)=yv(1,j)+acdipamp1* &
6584 &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
6585 yv(2,j)=yv(2,j)+acdipamp2* &
6586 &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
6587 endif
6588 if(nac.ge.(nramp1+nplato).and.(nramp2+nramp1+nplato).gt. &
6589 &nac)then
6590 yv(1,j)=yv(1,j)+acdipamp1*sin(2d0*pi*qd*nac+acphase)* &
6591 &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
6592 yv(2,j)=yv(2,j)+acdipamp2*sin(2d0*pi*qd*nac+acphase)* &
6593 &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
6594 endif
6595 enddo
6596 endif
6597 goto 640
6598
6599 !----------------------------
6600
6601 ! Wire.
6602
6603 748 continue
6604 ! magnetic rigidity
6605 chi = sqrt(e0*e0-pmap*pmap)*c1e6/clight
6606
6607 ix = ixcav
6608 tx = xrms(ix)
6609 ty = zrms(ix)
6610 dx = xpl(ix)
6611 dy = zpl(ix)
6612 embl = ek(ix)
6613 l = wirel(ix)
6614 cur = ed(ix)
6615
6616 leff = embl/cos(tx)/cos(ty)
6617 rx = dx *cos(tx)-embl*sin(tx)/2
6618 lin= dx *sin(tx)+embl*cos(tx)/2
6619 ry = dy *cos(ty)-lin *sin(ty)
6620 lin= lin*cos(ty)+dy *sin(ty)
6621
6622 do 750 j=1, napx
6623
6624 xv(1,j) = xv(1,j) * c1m3
6625 xv(2,j) = xv(2,j) * c1m3
6626 yv(1,j) = yv(1,j) * c1m3
6627 yv(2,j) = yv(2,j) * c1m3
6628
6629
6630
6631 xv(1,j) = xv(1,j) - embl/2*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
6632 &yv(2,j)**2)
6633 xv(2,j) = xv(2,j) - embl/2*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
6634 &yv(2,j)**2)
6635
6636
6637 xv(2,j) = xv(2,j)-xv(1,j)*sin(tx)*yv(2,j)/sqrt((1+dpsv(j))**2- &
6638 &yv(2,j)**2)/cos(atan(yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
6639 &yv(2,j)**2))-tx)
6640 xv(1,j) = xv(1,j)*(cos(tx)-sin(tx)*tan(atan(yv(1,j)/ &
6641 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-tx))
6642 yv(1,j) = sqrt((1+dpsv(j))**2-yv(2,j)**2)*sin(atan(yv(1,j)/ &
6643 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-tx)
6644
6645 xv(1,j) = xv(1,j)-xv(2,j)*sin(ty)*yv(1,j)/sqrt((1+dpsv(j))**2- &
6646 &yv(1,j)**2)/cos(atan(yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
6647 &yv(2,j)**2))-ty)
6648 xv(2,j) = xv(2,j)*(cos(ty)-sin(ty)*tan(atan(yv(2,j)/ &
6649 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-ty))
6650 yv(2,j) = sqrt((1+dpsv(j))**2-yv(1,j)**2)*sin(atan(yv(2,j)/ &
6651 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-ty)
6652
6653 xv(1,j) = xv(1,j) + lin*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
6654 &yv(2,j)**2)
6655 xv(2,j) = xv(2,j) + lin*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
6656 &yv(2,j)**2)
6657
6658 xi = xv(1,j)-rx
6659 yi = xv(2,j)-ry
6660 yv(1,j) = yv(1,j)-1.0d-7*cur/chi*xi/(xi**2+yi**2)* &
6661 &(sqrt((lin+l)**2+xi**2+yi**2)-sqrt((lin-l)**2+ &
6662 &xi**2+yi**2))
6663 !GRD FOR CONSISTENSY
6664 yv(2,j) = yv(2,j)-1.0d-7*cur/chi*yi/(xi**2+yi**2)* &
6665 &(sqrt((lin+l)**2+xi**2+yi**2)-sqrt((lin-l)**2+ &
6666 &xi**2+yi**2))
6667
6668 xv(1,j) = xv(1,j) + (leff-lin)*yv(1,j)/sqrt((1+dpsv(j))**2- &
6669 &yv(1,j)**2-yv(2,j)**2)
6670 xv(2,j) = xv(2,j) + (leff-lin)*yv(2,j)/sqrt((1+dpsv(j))**2- &
6671 &yv(1,j)**2-yv(2,j)**2)
6672
6673 xv(1,j) = xv(1,j)-xv(2,j)*sin(-ty)*yv(1,j)/sqrt((1+dpsv(j))**2- &
6674 &yv(1,j)**2)/cos(atan(yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
6675 &yv(2,j)**2))+ty)
6676 xv(2,j) = xv(2,j)*(cos(-ty)-sin(-ty)*tan(atan(yv(2,j)/ &
6677 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+ty))
6678 yv(2,j) = sqrt((1+dpsv(j))**2-yv(1,j)**2)*sin(atan(yv(2,j)/ &
6679 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+ty)
6680
6681 xv(2,j) = xv(2,j)-xv(1,j)*sin(-tx)*yv(2,j)/sqrt((1+dpsv(j))**2- &
6682 &yv(2,j)**2)/cos(atan(yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
6683 &yv(2,j)**2))+tx)
6684 xv(1,j) = xv(1,j)*(cos(-tx)-sin(-tx)*tan(atan(yv(1,j)/ &
6685 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+tx))
6686 yv(1,j) = sqrt((1+dpsv(j))**2-yv(2,j)**2)*sin(atan(yv(1,j)/ &
6687 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+tx)
6688
6689
6690 xv(1,j) = xv(1,j) + embl*tan(tx)
6691 xv(2,j) = xv(2,j) + embl*tan(ty)/cos(tx)
6692
6693 xv(1,j) = xv(1,j) - embl/2*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
6694 &yv(2,j)**2)
6695 xv(2,j) = xv(2,j) - embl/2*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
6696 &yv(2,j)**2)
6697
6698 xv(1,j) = xv(1,j) * c1e3
6699 xv(2,j) = xv(2,j) * c1e3
6700 yv(1,j) = yv(1,j) * c1e3
6701 yv(2,j) = yv(2,j) * c1e3
6702
6703 !-----------------------------------------------------------------------
6704
6705 750 continue
6706 goto 640
6707
6708 !----------------------------
6709
6710 640 continue
6711 !GRD
6712 !GRD UPGRADE JANUARY 2005
6713 !GRD
6714 if (firstrun) then
6715 if (rselect.gt.0 .and. rselect.lt.65) then
6716 do j = 1, napx
6717 !
6718 xj = (xv(1,j)-torbx(ie))/1d3
6719 xpj = (yv(1,j)-torbxp(ie))/1d3
6720 yj = (xv(2,j)-torby(ie))/1d3
6721 ypj = (yv(2,j)-torbyp(ie))/1d3
6722 pj = ejv(j)/1d3
6723 !GRD
6724 if (iturn.eq.1.and.j.eq.1) then
6725 sum_ax(ie)=0d0
6726 sum_ay(ie)=0d0
6727 endif
6728 !GRD
6729 !
6730 if (tbetax(ie).gt.0.) then
6731 gammax = (1d0 + talphax(ie)**2)/tbetax(ie)
6732 gammay = (1d0 + talphay(ie)**2)/tbetay(ie)
6733 else
6734 gammax = (1d0 + talphax(ie-1)**2)/tbetax(ie-1)
6735 gammay = (1d0 + talphay(ie-1)**2)/tbetay(ie-1)
6736 endif
6737 !
6738 if (part_abs(j).eq.0) then
6739 if(tbetax(ie).gt.0.) then
6740 nspx = sqrt( &
6741 & abs( gammax*(xj)**2 + &
6742 & 2d0*talphax(ie)*xj*xpj + &
6743 & tbetax(ie)*xpj**2 )/myemitx0 &
6744 & )
6745 nspy = sqrt( &
6746 & abs( gammay*(yj)**2 + &
6747 & 2d0*talphay(ie)*yj*ypj + &
6748 & tbetay(ie)*ypj**2 )/myemity0 &
6749 & )
6750 else
6751 nspx = sqrt( &
6752 & abs( gammax*(xj)**2 + &
6753 & 2d0*talphax(ie-1)*xj*xpj + &
6754 & tbetax(ie-1)*xpj**2 )/myemitx0 &
6755 & )
6756 nspy = sqrt( &
6757 & abs( gammay*(yj)**2 + &
6758 & 2d0*talphay(ie-1)*yj*ypj + &
6759 & tbetay(ie-1)*ypj**2 )/myemity0 &
6760 & )
6761 endif
6762
6763 xdebug(ie)=xj
6764 xpdebug(ie)=xpj
6765 ydebug(ie)=yj
6766 ypdebug(ie)=ypj
6767 xdebugN(ie)= xdebug(ie)/sqrt(myemitx0*tbetax(ie))
6768 xpdebugN(ie)=(xdebug(ie)*talphax(ie)+xpdebug(ie)*tbetax(ie))
6769 & /sqrt(myemitx0*tbetax(ie))
6770 ydebugN(ie)=ydebug(ie)/sqrt(myemity0*tbetay(ie))
6771 ypdebugN(ie)=(ydebug(ie)*talphay(ie)+ypdebug(ie)*tbetay(ie))
6772 & /sqrt(myemity0*tbetay(ie))
6773
6774 !
6775 sum_ax(ie) = sum_ax(ie) + nspx
6776 sqsum_ax(ie) = sqsum_ax(ie) + nspx**2
6777 sum_ay(ie) = sum_ay(ie) + nspy
6778 sqsum_ay(ie) = sqsum_ay(ie) + nspy**2
6779 nampl(ie) = nampl(ie) + 1
6780 else
6781 nspx = 0d0
6782 nspy = 0d0
6783 endif
6784 sampl(ie) = totals
6785 ename(ie) = bez(myix)(1:16)
6786 end do
6787 endif
6788 endif
6789 !GRD
6790 !GRD THIS LOOP MUST NOT BE WRITTEN INTO THE "IF(FIRSTRUN)" LOOP !!!!
6791 !GRD
6792 if (dowritetracks) then
6793 do j = 1, napx
6794 xj = (xv(1,j)-torbx(ie))/1d3
6795 xpj = (yv(1,j)-torbxp(ie))/1d3
6796 yj = (xv(2,j)-torby(ie))/1d3
6797 ypj = (yv(2,j)-torbyp(ie))/1d3
6798 !
6799 arcdx = 2.5d0
6800 arcbetax = 180d0
6801 !
6802 if (xj.le.0.) then
6803 xdisp = xj + (pj-myenom)/myenom * arcdx &
6804 &* sqrt(tbetax(ie)/arcbetax)
6805 else
6806 xdisp = xj - (pj-myenom)/myenom * arcdx &
6807 &* sqrt(tbetax(ie)/arcbetax)
6808 endif
6809 xndisp = xj
6810 nspxd = sqrt( &
6811 &abs(gammax*xdisp**2 + 2d0*talphax(ie)*xdisp*xpj &
6812 &+ tbetax(ie)*xpj**2)/myemitx0 &
6813 &)
6814 nspx = sqrt( &
6815 &abs( gammax*xndisp**2 + 2d0*talphax(ie)*xndisp* &
6816 &xpj + tbetax(ie)*xpj**2 )/myemitx0 &
6817 &)
6818 nspy = sqrt( &
6819 &abs( gammay*yj**2 + 2d0*talphay(ie)*yj &
6820 &*ypj + tbetay(ie)*ypj**2 )/myemity0 &
6821 &)
6822 !
6823 !
6824 !
6825 if(part_abs(j).eq.0) then
6826 if ((secondary(j).eq.1.or.tertiary(j).eq.2.or.other(j).eq.4) &
6827 & .and.(xv(1,j).lt.99d0 .and. xv(2,j).lt.99d0) .and. &
6828 !GRD
6829 !GRD HERE WE APPLY THE SAME KIND OF CUT THAN THE SIGSECUT PARAMETER
6830 !GRD &
6831 &( &
6832 &(( &
6833 &(xv(1,j)*1d-3)**2 &
6834 &/ &
6835 &(tbetax(ie)*myemitx0) &
6836 ! &).ge.sigsecut2).and. &
6837 &).ge.dble(sigsecut2)).or. &
6838 &(( &
6839 &(xv(2,j)*1d-3)**2 &
6840 &/ &
6841 &(tbetay(ie)*myemity0) &
6842 &).ge.dble(sigsecut2)).or. &
6843 &(((xv(1,j)*1d-3)**2/(tbetax(ie)*myemitx0))+ &
6844 &((xv(2,j)*1d-3)**2/(tbetay(ie)*myemity0)) &
6845 &.ge.sigsecut3) &
6846 &) ) then
6847 xj = (xv(1,j)-torbx(ie))/1d3
6848 xpj = (yv(1,j)-torbxp(ie))/1d3
6849 yj = (xv(2,j)-torby(ie))/1d3
6850 ypj = (yv(2,j)-torbyp(ie))/1d3
6851 write(38,'(1x,i8,1x,i4,1x,f8.2,5(1x,e11.3),1x,i4)') &
6852 &ipart(j)+100*samplenumber,iturn,sampl(ie), &
6853 &xv(1,j),yv(1,j), &
6854 &xv(2,j),yv(2,j),(ejv(j)-myenom)/myenom, &
6855 &secondary(j)+tertiary(j)+other(j)
6856 endif
6857 endif
6858 end do
6859 !!GRD+KAD here we dump the location within RHIC where any one transvere
6860 !!GRD+KAD dimension of the beam gets bigger than 4 cm => kind of like a
6861 !!GRD+KAD raw aperture check to obtain loss maps...
6862 !!GRD+KAD then we just delete the particle from the tracking, so as not to have
6863 !!GRD+KAD strange values for the impact parameter and have losses at other crazy
6864 !!GRD+KAD locations
6865 !!AUGUST2005 comment that out for LHC studies
6866 !!JUNE2005 here I close the "if(dowritetracks)" outside of the firstrun flag
6867 endif
6868 !GRD END OF UPGRADE
6869 kpz=abs(kp(ix))
6870 if(kpz.eq.0) goto 650
6871 if(kpz.eq.1) goto 650
6872 650 continue
6873 !GRD
6874 !UPGRADE JANUARY 2005
6875 !__________________________________________________________________
6876 !++ Now do analysis at selected elements...
6877 !
6878 !++ Save twiss functions of present element
6879 !
6880 ax0 = talphax(ie)
6881 bx0 = tbetax(ie)
6882 mux0 = mux(ie)
6883 ay0 = talphay(ie)
6884 by0 = tbetay(ie)
6885 muy0 = muy(ie)
6886 !GRD GET THE COORDINATES OF THE PARTICLES AT THE IEth ELEMENT:
6887 do j = 1,napx
6888 xgrd(j) = xv(1,j)
6889 xpgrd(j) = yv(1,j)
6890 ygrd(j) = xv(2,j)
6891 ypgrd(j) = yv(2,j)
6892 !
6893 xineff(j) = xv(1,j) &
6894 & - torbx(ie)
6895 xpineff(j) = yv(1,j) &
6896 & - torbxp(ie)
6897 yineff(j) = xv(2,j) &
6898 & - torby(ie)
6899 ypineff(j) = yv(2,j) &
6900 & - torbyp(ie)
6901 !
6902 pgrd(j) = ejv(j)
6903 ejfvgrd(j) = ejfv(j)
6904 sigmvgrd(j) = sigmv(j)
6905 rvvgrd(j) = rvv(j)
6906 dpsvgrd(j) = dpsv(j)
6907 oidpsvgrd(j) = oidpsv(j)
6908 dpsv1grd(j) = dpsv1(j)
6909 !GRD IMPORTANT: ALL PARTICLES ABSORBED ARE CONSIDERED TO BE LOST,
6910 !GRD SO WE GIVE THEM A LARGE OFFSET
6911 if (part_abs(j).ne.0) then
6912 xgrd(j) = 99.5d0
6913 ygrd(j) = 99.5d0
6914 endif
6915 end do
6916 !
6917 !++ For LAST ELEMENT in the ring calculate the number of surviving
6918 !++ particles and save into file versus turn number
6919 !
6920 if (ie.eq.iu) then
6921 nsurvive = 0
6922 do j = 1, napx
6923 if (xgrd(j).lt.99d0 .and. ygrd(j).lt.99d0) then
6924 nsurvive = nsurvive + 1
6925 endif
6926 end do
6927 write(44,*) iturn, nsurvive
6928 if (iturn.eq.numl) then
6929 nsurvive_end = nsurvive_end + nsurvive
6930 endif
6931 endif
6932 !
6933 !=======================================================================
6934 !++ Do collimation analysis at element 20 ("zero" turn) or LAST
6935 !++ ring element.
6936 !
6937 !++ If selecting, look at number of scattered particles at selected
6938 !++ collimator. For the "zero" turn consider the information at element
6939 !++ 20 (before collimation), otherwise take information at last ring
6940 !++ element.
6941 !
6942 if (do_coll .and. &
6943 & ( (iturn.eq.1 .and. ie.eq.20) .or. &
6944 & (ie.eq.iu) ) ) then
6945 !
6946 !++ Calculate gammas
6947 !------------------------------------------------------------------------
6948 !
6949 gammax = (1 + talphax(ie)**2)/tbetax(ie)
6950 gammay = (1 + talphay(ie)**2)/tbetay(ie)
6951 !
6952 !________________________________________________________________________
6953 !++ Loop over all particles.
6954 !
6955 do j = 1, napx
6956 !
6957 !------------------------------------------------------------------------
6958 !++ Save initial distribution of particles that were scattered on
6959 !++ the first turn at the selected primary collimator
6960 !
6961 !------------------------------------------------------------------------
6962 !++ Do the binning in amplitude, only considering particles that were
6963 !++ not absorbed before.
6964 !
6965 if (xgrd(j).lt.99d0 .and. ygrd(j) .lt.99d0 .and. &
6966 & (part_select(j).eq.1 .or. ie.eq.20)) then
6967 !
6968 !++ Normalized amplitudes are calculated
6969 !
6970 !++ Allow to apply some dispersive offset. Take arc dispersion (2m) and
6971 !++ normalize with arc beta_x function (180m).
6972 !
6973 arcdx = 2.5d0
6974 arcbetax = 180d0
6975 xdisp = abs(xgrd(j)*1d-3) + &
6976 & abs((pgrd(j)-myenom)/myenom)*arcdx &
6977 & * sqrt(tbetax(ie)/arcbetax)
6978 nspx = sqrt( &
6979 & abs(gammax*xdisp**2 + &
6980 & 2d0*talphax(ie)*xdisp*(xpgrd(j)*1d-3)+ &
6981 & tbetax(ie)*(xpgrd(j)*1d-3)**2 )/myemitx0 &
6982 & )
6983 nspy = sqrt( &
6984 & abs( gammay*(ygrd(j)*1d-3)**2 + &
6985 & 2d0*talphay(ie)*(ygrd(j)*1d-3*ypgrd(j)*1d-3) &
6986 & + tbetay(ie)*(ypgrd(j)*1d-3)**2 )/myemity0 &
6987 & )
6988 !
6989 !++ Populate the efficiency arrays at the end of each turn...
6990 !
6991 if (ie.eq.iu) then
6992 do ieff = 1, numeff
6993 if (counted_r(j,ieff).eq.0 .and. &
6994 &sqrt( &
6995 &((xineff(j)*1d-3)**2 &
6996 &/ &
6997 &(tbetax(ie)*myemitx0)) &
6998 &+ &
6999 &((yineff(j)*1d-3)**2 &
7000 &/ &
7001 &(tbetay(ie)*myemity0)) &
7002 &).ge.rsig(ieff)) then
7003 neff(ieff) = neff(ieff)+1d0
7004 counted_r(j,ieff)=1
7005 endif
7006 if (counted_x(j,ieff).eq.0 .and. &
7007 &sqrt( &
7008 &((xineff(j)*1d-3)**2 &
7009 &/ &
7010 &(tbetax(ie)*myemitx0)) &
7011 &).ge.rsig(ieff)) then
7012 neffx(ieff) = neffx(ieff) + 1d0
7013 counted_x(j,ieff)=1
7014 endif
7015 if (counted_y(j,ieff).eq.0 .and.
7016 &sqrt( &
7017 &((yineff(j)*1d-3)**2 &
7018 &/ &
7019 &(tbetay(ie)*myemity0)) &
7020 &).ge.rsig(ieff)) then
7021 neffy(ieff) = neffy(ieff) + 1d0
7022 counted_y(j,ieff)=1
7023 endif
7024 !
7025 end do
7026 endif
7027 !
7028 !++ Do an emittance drift
7029 !
7030 driftx = driftsx*sqrt(tbetax(ie)*myemitx0)
7031 drifty = driftsy*sqrt(tbetay(ie)*myemity0)
7032 if (ie.eq.iu) then
7033 dnormx = driftx / sqrt(tbetax(ie)*myemitx0)
7034 dnormy = drifty / sqrt(tbetay(ie)*myemity0)
7035 xnorm = (xgrd(j)*1d-3) / sqrt(tbetax(ie)*myemitx0)
7036 xpnorm = (talphax(ie)*(xgrd(j)*1d-3)+ &
7037 &tbetax(ie)*(xpgrd(j)*1d-3)) / &
7038 &sqrt(tbetax(ie)*myemitx0)
7039 if((xnorm.ne.0d0).and.(xpnorm.ne.0d0)) then
7040 xangle = atan2(xnorm,xpnorm)
7041 else
7042 xangle=0
7043 endif
7044 xnorm = xnorm + dnormx*sin(xangle)
7045 xpnorm = xpnorm + dnormx*cos(xangle)
7046 xgrd(j) = 1000d0*(xnorm * sqrt(tbetax(ie)*myemitx0))
7047 xpgrd(j) = 1000d0*((xpnorm*sqrt(tbetax(ie)*myemitx0)
7048 &-talphax(ie)*xgrd(j)*1d-3)/tbetax(ie))
7049 !
7050
7051 ynorm = (ygrd(j)*1d-3) / sqrt(tbetay(ie)*myemity0)
7052 ypnorm = (talphay(ie)*(ygrd(j)*1d-3)+ &
7053 &tbetay(ie)*(ypgrd(j)*1d-3)) / &
7054 &sqrt(tbetay(ie)*myemity0)
7055 if((ynorm.ne.0d0).and.(ypnorm.ne.0d0)) then
7056 yangle = atan2(ynorm,ypnorm)
7057 else
7058 yangle=0
7059 endif
7060 ynorm = ynorm + dnormy*sin(yangle)
7061 ypnorm = ypnorm + dnormy*cos(yangle)
7062 ygrd(j) = 1000d0*(ynorm * sqrt(tbetay(ie)*myemity0))
7063 ypgrd(j) = 1000d0*((ypnorm*sqrt(tbetay(ie)*myemity0) &
7064 &-talphay(ie)*ygrd(j)*1d-3)/tbetay(ie))
7065 endif
7066 !
7067 !------------------------------------------------------------------------
7068 !++ End of check for selection flag and absorption
7069 !
7070 endif
7071 !
7072 !++ End of do loop over particles
7073 !
7074 end do
7075 !
7076 !_________________________________________________________________
7077 !
7078 !++ End of collimation efficiency analysis for selected particles
7079 !
7080 end if
7081 !------------------------------------------------------------------
7082 !++ For LAST ELEMENT in the ring compact the arrays by moving all
7083 !++ lost particles to the end of the array.
7084 !
7085 if (ie.eq.iu) then
7086 imov = 0
7087 do j = 1, napx
7088 if (xgrd(j).lt.99d0 .and. ygrd(j).lt.99d0) then
7089 imov = imov + 1
7090 xgrd(imov) = xgrd(j)
7091 ygrd(imov) = ygrd(j)
7092 xpgrd(imov) = xpgrd(j)
7093 ypgrd(imov) = ypgrd(j)
7094 pgrd(imov) = pgrd(j)
7095 ejfvgrd(imov) = ejfvgrd(j)
7096 sigmvgrd(imov) = sigmvgrd(j)
7097 rvvgrd(imov) = rvvgrd(j)
7098 dpsvgrd(imov) = dpsvgrd(j)
7099 oidpsvgrd(imov) = oidpsvgrd(j)
7100 dpsv1grd(imov) = dpsv1grd(j)
7101 part_hit(imov) = part_hit(j)
7102 part_abs(imov) = part_abs(j)
7103 part_select(imov) = part_select(j)
7104 part_impact(imov) = part_impact(j)
7105 part_indiv(imov) = part_indiv(j)
7106 part_linteract(imov) = part_linteract(j)
7107 part_hit_before(imov) = part_hit_before(j)
7108 secondary(imov) = secondary(j)
7109 tertiary(imov) = tertiary(j)
7110 !GRD HERE WE ADD A MARKER FOR THE PARTICLE FORMER NAME
7111 ipart(imov) = ipart(j)
7112 flukaname(imov) = flukaname(j)
7113 do ieff = 1, numeff
7114 counted_r(imov,ieff) = counted_r(j,ieff)
7115 counted_x(imov,ieff) = counted_x(j,ieff)
7116 counted_y(imov,ieff) = counted_y(j,ieff)
7117 end do
7118 endif
7119 end do
7120 write(*,*) 'INFO> Compacted the particle distributions: ', &
7121 &napx, ' --> ', imov
7122 napx = imov
7123 endif
7124 !GRD
7125 !
7126 !------------------------------------------------------------------------
7127 !
7128 !++ Write final distribution
7129 !
7130 if (dowrite_dist.and.(ie.eq.iu).and.(n.eq.numl)) then
7131 open(unit=99, file='distn.dat')
7132 write(99,*) &
7133 &'# 1=x 2=xp 3=y 4=yp'
7134 do j = 1, napx
7135 write(99,'(5(1X,E15.7))') xgrd(j), xpgrd(j), &
7136 &ygrd(j), ypgrd(j)
7137 ! 2 , S(J)
7138 end do
7139 close(99)
7140 endif
7141 !
7142 !GRD
7143 !GRD NOW ONE HAS TO COPY BACK THE NEW DISTRIBUTION TO ITS "ORIGINAL NAME"
7144 !GRD AT THE END OF EACH TURN
7145 !GRD
7146 if (ie.eq.iu) then
7147 do j = 1,napx
7148 xv(1,j) = xgrd(j)
7149 yv(1,j) = xpgrd(j)
7150 xv(2,j) = ygrd(j)
7151 yv(2,j) = ypgrd(j)
7152 ejv(j) = pgrd(j)
7153 ejfv(j) = ejfvgrd(j)
7154 sigmv(j) = sigmvgrd(j)
7155 rvv(j) = rvvgrd(j)
7156 dpsv(j) = dpsvgrd(j)
7157 oidpsv(j) = oidpsvgrd(j)
7158 dpsv1(j) = dpsv1grd(j)
7159 end do
7160 endif
7161 if (firstrun) then
7162 if (rselect.gt.0 .and. rselect.lt.65) then
7163 do j = 1, napx
7164 !
7165 xj = (xv(1,j)-torbx(ie))/1d3
7166 xpj = (yv(1,j)-torbxp(ie))/1d3
7167 yj = (xv(2,j)-torby(ie))/1d3
7168 ypj = (yv(2,j)-torbyp(ie))/1d3
7169 pj = ejv(j)/1d3
7170 if (iturn.eq.1.and.j.eq.1) then
7171 sum_ax(ie)=0d0
7172 sum_ay(ie)=0d0
7173 endif
7174 if (tbetax(ie).gt.0.) then
7175 gammax = (1d0 + talphax(ie)**2)/tbetax(ie)
7176 gammay = (1d0 + talphay(ie)**2)/tbetay(ie)
7177 else
7178 gammax = (1d0 + talphax(ie-1)**2)/tbetax(ie-1)
7179 gammay = (1d0 + talphay(ie-1)**2)/tbetay(ie-1)
7180 endif
7181 !
7182 if (part_abs(j).eq.0) then
7183 if(tbetax(ie).gt.0.) then
7184 nspx = sqrt( &
7185 &abs( gammax*(xj)**2 + &
7186 &2d0*talphax(ie)*xj*xpj + &
7187 &tbetax(ie)*xpj**2 )/myemitx0 &
7188 &)
7189 nspy = sqrt( &
7190 &abs( gammay*(yj)**2 + &
7191 &2d0*talphay(ie)*yj*ypj + &
7192 &tbetay(ie)*ypj**2 )/myemity0 &
7193 &)
7194 else
7195 nspx = sqrt( &
7196 &abs( gammax*(xj)**2 + &
7197 &2d0*talphax(ie-1)*xj*xpj + &
7198 &tbetax(ie-1)*xpj**2 )/myemitx0 &
7199 &)
7200 nspy = sqrt( &
7201 &abs( gammay*(yj)**2 + &
7202 &2d0*talphay(ie-1)*yj*ypj + &
7203 &tbetay(ie-1)*ypj**2 )/myemity0 &
7204 &)
7205 endif
7206 !
7207
7208 xdebug(ie)=xj
7209 xpdebug(ie)=xpj
7210 ydebug(ie)=yj
7211 ypdebug(ie)=ypj
7212 xdebugN(ie)= xdebug(ie)/sqrt(myemitx0*tbetax(ie))
7213 xpdebugN(ie)=(xdebug(ie)*talphax(ie)+xpdebug(ie)*tbetax(ie))
7214 & /sqrt(myemitx0*tbetax(ie))
7215 ydebugN(ie)=ydebug(ie)/sqrt(myemity0*tbetay(ie))
7216 ypdebugN(ie)=(ydebug(ie)*talphay(ie)+ypdebug(ie)*tbetay(ie))
7217 & /sqrt(myemity0*tbetay(ie))
7218
7219 sum_ax(ie) = sum_ax(ie) + nspx
7220 sqsum_ax(ie) = sqsum_ax(ie) + nspx**2
7221 sum_ay(ie) = sum_ay(ie) + nspy
7222 sqsum_ay(ie) = sqsum_ay(ie) + nspy**2
7223 nampl(ie) = nampl(ie) + 1
7224 sampl(ie) = totals
7225 ename(ie) = bez(myix)(1:16)
7226 else
7227 nspx = 0d0
7228 nspy = 0d0
7229 endif
7230 end do
7231 endif
7232 endif
7233 !GRD
7234 !GRD THIS LOOP MUST NOT BE WRITTEN INTO THE "IF(FIRSTRUN)" LOOP !!!!
7235 !GRD
7236 if (dowritetracks) then
7237 do j = 1, napx
7238 xj = (xv(1,j)-torbx(ie))/1d3
7239 xpj = (yv(1,j)-torbxp(ie))/1d3
7240 yj = (xv(2,j)-torby(ie))/1d3
7241 ypj = (yv(2,j)-torbyp(ie))/1d3
7242 !
7243 arcdx = 2.5d0
7244 arcbetax = 180d0
7245 !
7246 if (xj.le.0.) then
7247 xdisp = xj + (pj-myenom)/myenom * arcdx &
7248 &* sqrt(tbetax(ie)/arcbetax)
7249 else
7250 xdisp = xj - (pj-myenom)/myenom * arcdx &
7251 &* sqrt(tbetax(ie)/arcbetax)
7252 endif
7253 xndisp = xj
7254 nspxd = sqrt( &
7255 &abs(gammax*xdisp**2 + 2d0*talphax(ie)*xdisp*xpj &
7256 &+ tbetax(ie)*xpj**2)/myemitx0 &
7257 &)
7258 nspx = sqrt( &
7259 &abs( gammax*xndisp**2 + 2d0*talphax(ie)*xndisp* &
7260 &xpj + tbetax(ie)*xpj**2 )/myemitx0 &
7261 &)
7262 nspy = sqrt( &
7263 &abs( gammay*yj**2 + 2d0*talphay(ie)*yj &
7264 &*ypj + tbetay(ie)*ypj**2 )/myemity0 &
7265 &)
7266 !
7267 !
7268 !
7269 if(part_abs(j).eq.0) then
7270 if ((secondary(j).eq.1.or.tertiary(j).eq.2.or.other(j).eq.4) &
7271 &.and.(xv(1,j).lt.99d0 .and. xv(2,j).lt.99d0) .and. &
7272 !GRD
7273 !GRD HERE WE APPLY THE SAME KIND OF CUT THAN THE SIGSECUT PARAMETER
7274 !GRD &
7275 &( &
7276 &(( &
7277 &(xv(1,j)*1d-3)**2 &
7278 &/ &
7279 &(tbetax(ie)*myemitx0) &
7280 &).ge.dble(sigsecut2)).or. &
7281 &(( &
7282 &(xv(2,j)*1d-3)**2 &
7283 &/ &
7284 &(tbetay(ie)*myemity0) &
7285 &).ge.dble(sigsecut2)).or. &
7286 &(((xv(1,j)*1d-3)**2/(tbetax(ie)*myemitx0))+ &
7287 &((xv(2,j)*1d-3)**2/(tbetay(ie)*myemity0)) &
7288 &.ge.sigsecut3) &
7289 &) ) then
7290 xj = (xv(1,j)-torbx(ie))/1d3
7291 xpj = (yv(1,j)-torbxp(ie))/1d3
7292 yj = (xv(2,j)-torby(ie))/1d3
7293 ypj = (yv(2,j)-torbyp(ie))/1d3
7294 write(38,'(1x,i8,1x,i4,1x,f8.2,5(1x,e11.3),1x,i4)') &
7295 &ipart(j)+100*samplenumber,iturn,sampl(ie), &
7296 &xv(1,j),yv(1,j), &
7297 &xv(2,j),yv(2,j),(ejv(j)-myenom)/myenom, &
7298 &secondary(j)+tertiary(j)+other(j)
7299 endif
7300 endif
7301 end do
7302 endif
7303 !=======================================================================
7304 !GRD END OF UPGRADE
7305 660 continue
7306 close(99)
7307 close(53)
7308 !GRD HERE WE SET THE FLAG FOR INITIALIZATION TO FALSE AFTER TURN 1
7309 firstrun = .false.
7310 return
7311 end
7312 !
7313 !==============================================================================
7314 !
7315 subroutine thin6dua(nthinerr)
7316 !-----------------------------------------------------------------------
7317 !
7318 ! TRACK THIN LENS 6D WITH ACCELERATION
7319 !
7320 !
7321 ! F. SCHMIDT
7322 !-----------------------------------------------------------------------
7323 implicit none
7324 integer i,irrtr,ix,j,k,kpz,n,nmz,nthinerr
7325 double precision c5m4,cbxb,cbzb,cccc,cikve,cikveb,crkve,crkveb, &
7326 &crkveuk,crxb,crzb,dpsv3,pux,e0fo,e0o,r0,r2b,rb,rho2b,rkb,stracki, &
7327 &tkb,xbb,xlvj,xrb,yv1j,yv2j,zbb,zlvj,zrb
7328 integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1, &
7329 &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran, &
7330 &nrco,ntr,nzfz
7331 parameter(npart = 64,nmac = 1)
7332 parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000, &
7333 &nzfz = 300000,mmul = 11)
7334 parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5, &
7335 &nema = 15)
7336 parameter(mcor = 10,mcop = mcor+6, mbea = 15)
7337 parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
7338 parameter(nmon1 = 600,ncor1 = 600)
7339 parameter(ntr = 20,nbb = 160)
7340 integer ireturn, xory, nac, nfree, nramp1,nplato, nramp2
7341 double precision xv1j,xv2j
7342 double precision acdipamp, qd, acphase,acdipamp2, &
7343 &acdipamp1
7344 double precision l,cur,dx,dy,tx,ty,embl,leff,rx,ry,lin,chi,xi,yi
7345 logical llost
7346 double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3, &
7347 &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21, &
7348 &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
7349 &one,pieni,pmae,pmap,three,two,zero
7350 parameter(pieni = 1d-38)
7351 parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
7352 parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
7353 parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
7354 parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
7355 parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 = &
7356 &1.0d16)
7357 parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
7358 parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
7359 parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
7360 parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
7361 parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
7362 parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
7363 parameter(pmap = 938.271998d0,pmae = .510998902d0)
7364 parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
7365 integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo, &
7366 &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor, &
7367 &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb, &
7368 &imc,imtr,iorg,iout, &
7369 &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires, &
7370 &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw, &
7371 &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox, &
7372 &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo, &
7373 &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx, &
7374 &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr, &
7375 &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew, &
7376 &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr, &
7377 &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
7378 double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu, &
7379 &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
7380 &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft, &
7381 &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
7382 &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign, &
7383 &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum, &
7384 &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
7385 &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph, &
7386 &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
7387 &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel, &
7388 &acdipph
7389 real hmal
7390 character*16 bez,bezb,bezr,erbez,bezl
7391 character*80 toptit,sixtit,commen
7392 common/erro/ierro,erbez
7393 common/kons/pi,pi2,pisqrt,rad
7394 common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
7395 common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
7396 common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
7397 common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
7398 common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
7399 common/syos2/rvf(mpa)
7400 common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
7401 &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
7402 common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3), &
7403 &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen, &
7404 &iicav,itionc(nele),ition,idp,ncy,ixcav
7405 common/corcom/dpscor,sigcor,icode,idam,its6d
7406 common/multi/bk0(nele,mmul),ak0(nele,mmul), &
7407 &bka(nele,mmul),aka(nele,mmul)
7408 common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
7409 common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
7410 common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz), &
7411 &tilts(nblz),mout2,icext(nblz),icextal(nblz)
7412 common/beo /aper(2),di0(2),dip0(2),ta(6,6)
7413 common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
7414 &iout
7415 common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
7416 common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint, &
7417 &ntco,eui,euii,nlin,bezl(nele)
7418 common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2), &
7419 &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr, &
7420 &ncororb(nele)
7421 common/apert/apx(nele),apz(nele),ape(3,nele)
7422 common/clos/sigma0(2),iclo,ncorru,ncorrep
7423 common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20), &
7424 &ratioe(nele),iratioe(nele),icoe
7425 common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
7426 common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
7427 common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
7428 common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
7429 common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2, &
7430 &nstart,nstop,iskip,iconv,imad
7431 common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
7432 common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
7433 common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
7434 common/ripp2/nrturn
7435 common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
7436 common/pawc/hmal(nplo)
7437 common/tit/sixtit,commen,ithick
7438 common/co6d/clo6(3),clop6(3)
7439 common/dkic/dki(nele,3)
7440 common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb), &
7441 &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart), &
7442 &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar, &
7443 &nbeam,ibbc,ibeco,ibtyp,lhc
7444 common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
7445 common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
7446 common/wireco/ wirel(nele)
7447 common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele), &
7448 &nturn3(nele), nturn4(nele)
7449 integer idz,itra
7450 double precision al,as,chi0,chid,dp1,dps,exz,sigm
7451 common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa), &
7452 &dps(mpa),idz(2)
7453 common/anf/chi0,chid,exz(2,6),dp1,itra
7454 integer ichrom,is
7455 double precision alf0,amp,bet0,clo,clop,cro,x,y
7456 common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
7457 common/chrom/cro(2),is(2),ichrom
7458 integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
7459 &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
7460 double precision dpmax,preda,weig1,weig2
7461 character*16 coel
7462 common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
7463 common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
7464 common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
7465 &coel(10)
7466 double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
7467 &zsi
7468 real tlim,time0,time1
7469 common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz), &
7470 &aai(nblz,mmul),bbi(nblz,mmul)
7471 common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
7472 common/damp/damp,ampt
7473 common/ttime/tlim,time0,time1
7474 double precision tasm
7475 common/tasm/tasm(6,6)
7476 integer iv,ixv,nlostp,nms,numxv
7477 double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
7478 &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
7479 &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl, &
7480 &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
7481 &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv, &
7482 &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas, &
7483 &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
7484 &zsiv,zsv
7485 logical pstop
7486 common/main1/ &
7487 &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz), &
7488 &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz), &
7489 &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2), &
7490 &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart), &
7491 &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart), &
7492 &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart), &
7493 &xlv(npart),zlv(npart),pstop(npart),rvv(npart), &
7494 &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
7495 common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart), &
7496 &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart), &
7497 &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart), &
7498 &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart), &
7499 &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart), &
7500 &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
7501 &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
7502 &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart), &
7503 &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
7504 common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo), &
7505 &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart), &
7506 &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6), &
7507 &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
7508 integer numx
7509 double precision e0f
7510 common/main4/ e0f,numx
7511 integer ktrack,nwri
7512 double precision dpsv1,strack,strackc,stracks
7513 common/track/ ktrack(nblz),strack(nblz),strackc(nblz), &
7514 &stracks(nblz),dpsv1(npart),nwri
7515 double precision cc,xlim,ylim
7516 parameter(cc = 1.12837916709551d0)
7517 parameter(xlim = 5.33d0)
7518 parameter(ylim = 4.29d0)
7519 dimension crkveb(npart),cikveb(npart),rho2b(npart),tkb(npart), &
7520 &r2b(npart),rb(npart),rkb(npart), &
7521 &xrb(npart),zrb(npart),xbb(npart),zbb(npart),crxb(npart), &
7522 &crzb(npart),cbxb(npart),cbzb(npart)
7523 dimension dpsv3(npart)
7524 save
7525 !-----------------------------------------------------------------------
7526 c5m4=5.0d-4
7527 nthinerr=0
7528 do 660 n=1,numl
7529 numx=n-1
7530 if(irip.eq.1) call ripple(n)
7531 if(n.le.nde(1)) nwri=nwr(1)
7532 if(n.gt.nde(1).and.n.le.nde(2)) nwri=nwr(2)
7533 if(n.gt.nde(2)) nwri=nwr(3)
7534 if(nwri.eq.0) nwri=numl+numlr+1
7535 if(mod(numx,nwri).eq.0) call writebin(nthinerr)
7536 if(nthinerr.ne.0) return
7537 do 650 i=1,iu
7538 ix=ic(i)-nblo
7539 !--------count44
7540 goto(10,30,740,650,650,650,650,650,650,650,50,70,90,110,130, &
7541 &150,170,190,210,230,440,460,480,500,520,540,560,580,600,620, &
7542 &640,410,250,270,290,310,330,350,370,390,680,700,720,730,748, &
7543 &650,650,650,650,650,745,746),ktrack(i)
7544 goto 650
7545 10 stracki=strack(i)
7546 do 20 j=1,napx
7547 xv(1,j)=xv(1,j)+stracki*yv(1,j)
7548 xv(2,j)=xv(2,j)+stracki*yv(2,j)
7549 sigmv(j)=sigmv(j)+stracki*(c1e3-rvv(j)*(c1e3+(yv(1,j) &
7550 &*yv(1,j)+yv(2,j)*yv(2,j))*c5m4))
7551 20 continue
7552 goto 650
7553 30 e0o=e0
7554 e0fo=e0f
7555 call adia(n,e0f)
7556 do 40 j=1,napx
7557 ejf0v(j)=ejfv(j)
7558 if(abs(dppoff).gt.pieni) sigmv(j)=sigmv(j)-sigmoff(i)
7559 if(sigmv(j).lt.zero) sigmv(j)=e0f*e0o/(e0fo*e0)*sigmv(j)
7560 if(kz(ix).eq.12) then
7561 ejv(j)=ejv(j)+ed(ix)*sin(hsyc(ix)*sigmv(j)+phas+ &
7562 &phasc(ix))
7563 else
7564 ejv(j)=ejv(j)+hsy(1)*sin(hsy(3)*sigmv(j)+phas)
7565 endif
7566 ejfv(j)=sqrt(ejv(j)*ejv(j)-pma*pma)
7567 rvv(j)=(ejv(j)*e0f)/(e0*ejfv(j))
7568 dpsv(j)=(ejfv(j)-e0f)/e0f
7569 oidpsv(j)=one/(one+dpsv(j))
7570 dpsv1(j)=dpsv(j)*c1e3*oidpsv(j)
7571 if(sigmv(j).gt.zero) sigmv(j)=e0f*e0o/(e0fo*e0)*sigmv(j)
7572 yv(1,j)=ejf0v(j)/ejfv(j)*yv(1,j)
7573 40 yv(2,j)=ejf0v(j)/ejfv(j)*yv(2,j)
7574 if(n.eq.1) write(98,'(1p,6(2x,e25.18))') &
7575 &(xv(1,j),yv(1,j),xv(2,j),yv(2,j),sigmv(j),dpsv(j),j=1,napx)
7576 goto 640
7577 !--HORIZONTAL DIPOLE
7578 50 do 60 j=1,napx
7579 yv(1,j)=yv(1,j)+strackc(i)*oidpsv(j)
7580 yv(2,j)=yv(2,j)+stracks(i)*oidpsv(j)
7581 60 continue
7582 goto 640
7583 !--NORMAL QUADRUPOLE
7584 70 do 80 j=1,napx
7585 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
7586 &(xv(2,j)-zsiv(1,i))*tilts(i)
7587 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
7588 &(xv(2,j)-zsiv(1,i))*tiltc(i)
7589 crkve=xlv(j)
7590 cikve=zlv(j)
7591 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
7592 &stracks(i)*cikve)
7593 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
7594 &stracks(i)*crkve)
7595 80 continue
7596 goto 640
7597 !--NORMAL SEXTUPOLE
7598 90 do 100 j=1,napx
7599 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
7600 &(xv(2,j)-zsiv(1,i))*tilts(i)
7601 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
7602 &(xv(2,j)-zsiv(1,i))*tiltc(i)
7603 crkve=xlv(j)
7604 cikve=zlv(j)
7605 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7606 cikve=crkve*zlv(j)+cikve*xlv(j)
7607 crkve=crkveuk
7608 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
7609 &stracks(i)*cikve)
7610 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
7611 &stracks(i)*crkve)
7612 100 continue
7613 goto 640
7614 !--NORMAL OCTUPOLE
7615 110 do 120 j=1,napx
7616 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
7617 &(xv(2,j)-zsiv(1,i))*tilts(i)
7618 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
7619 &(xv(2,j)-zsiv(1,i))*tiltc(i)
7620 crkve=xlv(j)
7621 cikve=zlv(j)
7622 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7623 cikve=crkve*zlv(j)+cikve*xlv(j)
7624 crkve=crkveuk
7625 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7626 cikve=crkve*zlv(j)+cikve*xlv(j)
7627 crkve=crkveuk
7628 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
7629 &stracks(i)*cikve)
7630 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
7631 &stracks(i)*crkve)
7632 120 continue
7633 goto 640
7634 !--NORMAL DECAPOLE
7635 130 do 140 j=1,napx
7636 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
7637 &(xv(2,j)-zsiv(1,i))*tilts(i)
7638 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
7639 &(xv(2,j)-zsiv(1,i))*tiltc(i)
7640 crkve=xlv(j)
7641 cikve=zlv(j)
7642 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7643 cikve=crkve*zlv(j)+cikve*xlv(j)
7644 crkve=crkveuk
7645 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7646 cikve=crkve*zlv(j)+cikve*xlv(j)
7647 crkve=crkveuk
7648 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7649 cikve=crkve*zlv(j)+cikve*xlv(j)
7650 crkve=crkveuk
7651 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
7652 &stracks(i)*cikve)
7653 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
7654 &stracks(i)*crkve)
7655 140 continue
7656 goto 640
7657 !--NORMAL DODECAPOLE
7658 150 do 160 j=1,napx
7659 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
7660 &(xv(2,j)-zsiv(1,i))*tilts(i)
7661 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
7662 &(xv(2,j)-zsiv(1,i))*tiltc(i)
7663 crkve=xlv(j)
7664 cikve=zlv(j)
7665 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7666 cikve=crkve*zlv(j)+cikve*xlv(j)
7667 crkve=crkveuk
7668 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7669 cikve=crkve*zlv(j)+cikve*xlv(j)
7670 crkve=crkveuk
7671 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7672 cikve=crkve*zlv(j)+cikve*xlv(j)
7673 crkve=crkveuk
7674 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7675 cikve=crkve*zlv(j)+cikve*xlv(j)
7676 crkve=crkveuk
7677 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
7678 &stracks(i)*cikve)
7679 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
7680 &stracks(i)*crkve)
7681 160 continue
7682 goto 640
7683 !--NORMAL 14-POLE
7684 170 do 180 j=1,napx
7685 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
7686 &(xv(2,j)-zsiv(1,i))*tilts(i)
7687 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
7688 &(xv(2,j)-zsiv(1,i))*tiltc(i)
7689 crkve=xlv(j)
7690 cikve=zlv(j)
7691 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7692 cikve=crkve*zlv(j)+cikve*xlv(j)
7693 crkve=crkveuk
7694 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7695 cikve=crkve*zlv(j)+cikve*xlv(j)
7696 crkve=crkveuk
7697 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7698 cikve=crkve*zlv(j)+cikve*xlv(j)
7699 crkve=crkveuk
7700 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7701 cikve=crkve*zlv(j)+cikve*xlv(j)
7702 crkve=crkveuk
7703 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7704 cikve=crkve*zlv(j)+cikve*xlv(j)
7705 crkve=crkveuk
7706 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
7707 &stracks(i)*cikve)
7708 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
7709 &stracks(i)*crkve)
7710 180 continue
7711 goto 640
7712 !--NORMAL 16-POLE
7713 190 do 200 j=1,napx
7714 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
7715 &(xv(2,j)-zsiv(1,i))*tilts(i)
7716 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
7717 &(xv(2,j)-zsiv(1,i))*tiltc(i)
7718 crkve=xlv(j)
7719 cikve=zlv(j)
7720 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7721 cikve=crkve*zlv(j)+cikve*xlv(j)
7722 crkve=crkveuk
7723 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7724 cikve=crkve*zlv(j)+cikve*xlv(j)
7725 crkve=crkveuk
7726 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7727 cikve=crkve*zlv(j)+cikve*xlv(j)
7728 crkve=crkveuk
7729 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7730 cikve=crkve*zlv(j)+cikve*xlv(j)
7731 crkve=crkveuk
7732 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7733 cikve=crkve*zlv(j)+cikve*xlv(j)
7734 crkve=crkveuk
7735 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7736 cikve=crkve*zlv(j)+cikve*xlv(j)
7737 crkve=crkveuk
7738 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
7739 &stracks(i)*cikve)
7740 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
7741 &stracks(i)*crkve)
7742 200 continue
7743 goto 640
7744 !--NORMAL 18-POLE
7745 210 do 220 j=1,napx
7746 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
7747 &(xv(2,j)-zsiv(1,i))*tilts(i)
7748 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
7749 &(xv(2,j)-zsiv(1,i))*tiltc(i)
7750 crkve=xlv(j)
7751 cikve=zlv(j)
7752 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7753 cikve=crkve*zlv(j)+cikve*xlv(j)
7754 crkve=crkveuk
7755 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7756 cikve=crkve*zlv(j)+cikve*xlv(j)
7757 crkve=crkveuk
7758 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7759 cikve=crkve*zlv(j)+cikve*xlv(j)
7760 crkve=crkveuk
7761 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7762 cikve=crkve*zlv(j)+cikve*xlv(j)
7763 crkve=crkveuk
7764 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7765 cikve=crkve*zlv(j)+cikve*xlv(j)
7766 crkve=crkveuk
7767 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7768 cikve=crkve*zlv(j)+cikve*xlv(j)
7769 crkve=crkveuk
7770 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7771 cikve=crkve*zlv(j)+cikve*xlv(j)
7772 crkve=crkveuk
7773 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
7774 &stracks(i)*cikve)
7775 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
7776 &stracks(i)*crkve)
7777 220 continue
7778 goto 640
7779 !--NORMAL 20-POLE
7780 230 do 240 j=1,napx
7781 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
7782 &(xv(2,j)-zsiv(1,i))*tilts(i)
7783 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
7784 &(xv(2,j)-zsiv(1,i))*tiltc(i)
7785 crkve=xlv(j)
7786 cikve=zlv(j)
7787 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7788 cikve=crkve*zlv(j)+cikve*xlv(j)
7789 crkve=crkveuk
7790 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7791 cikve=crkve*zlv(j)+cikve*xlv(j)
7792 crkve=crkveuk
7793 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7794 cikve=crkve*zlv(j)+cikve*xlv(j)
7795 crkve=crkveuk
7796 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7797 cikve=crkve*zlv(j)+cikve*xlv(j)
7798 crkve=crkveuk
7799 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7800 cikve=crkve*zlv(j)+cikve*xlv(j)
7801 crkve=crkveuk
7802 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7803 cikve=crkve*zlv(j)+cikve*xlv(j)
7804 crkve=crkveuk
7805 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7806 cikve=crkve*zlv(j)+cikve*xlv(j)
7807 crkve=crkveuk
7808 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7809 cikve=crkve*zlv(j)+cikve*xlv(j)
7810 crkve=crkveuk
7811 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
7812 &stracks(i)*cikve)
7813 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
7814 &stracks(i)*crkve)
7815 240 continue
7816 goto 640
7817 250 continue
7818 do 260 j=1,napx
7819 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
7820 &(xv(2,j)-zsiv(1,i))*tilts(i)
7821 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
7822 &(xv(2,j)-zsiv(1,i))*tiltc(i)
7823 yv(1,j)=yv(1,j)-(strack(i)*xlvj*oidpsv(j) &
7824 &+dpsv1(j))*dki(ix,1)*tiltc(i) &
7825 &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
7826 yv(2,j)=yv(2,j)-(strack(i)*xlvj*oidpsv(j) &
7827 &+dpsv1(j))*dki(ix,1)*tilts(i) &
7828 &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
7829 sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
7830 260 continue
7831 goto 640
7832 270 continue
7833 do 280 j=1,napx
7834 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
7835 &(xv(2,j)-zsiv(1,i))*tilts(i)
7836 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
7837 &(xv(2,j)-zsiv(1,i))*tiltc(i)
7838 yv(1,j)=yv(1,j)-(strack(i)*xlvj*oidpsv(j) &
7839 &+dpsv1(j))*dki(ix,1)*tiltc(i) &
7840 &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
7841 yv(2,j)=yv(2,j)-(strack(i)*xlvj*oidpsv(j) &
7842 &+dpsv1(j))*dki(ix,1)*tilts(i) &
7843 &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
7844 sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
7845 280 continue
7846 goto 410
7847 290 continue
7848 do 300 j=1,napx
7849 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
7850 &(xv(2,j)-zsiv(1,i))*tilts(i)
7851 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
7852 &(xv(2,j)-zsiv(1,i))*tiltc(i)
7853 yv(1,j)=yv(1,j)-strackc(i)*dpsv1(j) &
7854 &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
7855 yv(2,j)=yv(2,j)-stracks(i)*dpsv1(j) &
7856 &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
7857 sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
7858 300 continue
7859 goto 640
7860 310 continue
7861 do 320 j=1,napx
7862 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
7863 &(xv(2,j)-zsiv(1,i))*tilts(i)
7864 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
7865 &(xv(2,j)-zsiv(1,i))*tiltc(i)
7866 yv(1,j)=yv(1,j)-strackc(i)*dpsv1(j) &
7867 &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
7868 yv(2,j)=yv(2,j)-stracks(i)*dpsv1(j) &
7869 &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
7870 sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
7871 320 continue
7872 goto 410
7873 330 continue
7874 do 340 j=1,napx
7875 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
7876 &(xv(2,j)-zsiv(1,i))*tilts(i)
7877 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
7878 &(xv(2,j)-zsiv(1,i))*tiltc(i)
7879 yv(1,j)=yv(1,j)+(strack(i)*zlvj*oidpsv(j) &
7880 &-dpsv1(j))*dki(ix,2)*tilts(i) &
7881 &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
7882 yv(2,j)=yv(2,j)-(strack(i)*zlvj*oidpsv(j) &
7883 &-dpsv1(j))*dki(ix,2)*tiltc(i) &
7884 &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
7885 sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
7886 340 continue
7887 goto 640
7888 350 continue
7889 do 360 j=1,napx
7890 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
7891 &(xv(2,j)-zsiv(1,i))*tilts(i)
7892 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
7893 &(xv(2,j)-zsiv(1,i))*tiltc(i)
7894 yv(1,j)=yv(1,j)+(strack(i)*zlvj*oidpsv(j) &
7895 &-dpsv1(j))*dki(ix,2)*tilts(i) &
7896 &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
7897 yv(2,j)=yv(2,j)-(strack(i)*zlvj*oidpsv(j) &
7898 &-dpsv1(j))*dki(ix,2)*tiltc(i) &
7899 &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
7900 sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
7901 360 continue
7902 goto 410
7903 370 continue
7904 do 380 j=1,napx
7905 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
7906 &(xv(2,j)-zsiv(1,i))*tilts(i)
7907 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
7908 &(xv(2,j)-zsiv(1,i))*tiltc(i)
7909 yv(1,j)=yv(1,j)-stracks(i)*dpsv1(j) &
7910 &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
7911 yv(2,j)=yv(2,j)+strackc(i)*dpsv1(j) &
7912 &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
7913 sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
7914 380 continue
7915 goto 640
7916 390 continue
7917 do 400 j=1,napx
7918 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
7919 &(xv(2,j)-zsiv(1,i))*tilts(i)
7920 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
7921 &(xv(2,j)-zsiv(1,i))*tiltc(i)
7922 yv(1,j)=yv(1,j)-stracks(i)*dpsv1(j) &
7923 &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
7924 yv(2,j)=yv(2,j)+strackc(i)*dpsv1(j) &
7925 &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
7926 sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
7927 400 continue
7928 410 r0=ek(ix)
7929 nmz=nmu(ix)
7930 if(nmz.ge.2) then
7931 do 430 j=1,napx
7932 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
7933 &(xv(2,j)-zsiv(1,i))*tilts(i)
7934 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
7935 &(xv(2,j)-zsiv(1,i))*tiltc(i)
7936 yv1j=bbiv(1,1,i)+bbiv(2,1,i)*xlvj+aaiv(2,1,i)*zlvj
7937 yv2j=aaiv(1,1,i)-bbiv(2,1,i)*zlvj+aaiv(2,1,i)*xlvj
7938 crkve=xlvj
7939 cikve=zlvj
7940 do 420 k=3,nmz
7941 crkveuk=crkve*xlvj-cikve*zlvj
7942 cikve=crkve*zlvj+cikve*xlvj
7943 crkve=crkveuk
7944 yv1j=yv1j+bbiv(k,1,i)*crkve+aaiv(k,1,i)*cikve
7945 yv2j=yv2j-bbiv(k,1,i)*cikve+aaiv(k,1,i)*crkve
7946 420 continue
7947 yv(1,j)=yv(1,j)+(tiltc(i)*yv1j-tilts(i)*yv2j)*oidpsv(j)
7948 yv(2,j)=yv(2,j)+(tiltc(i)*yv2j+tilts(i)*yv1j)*oidpsv(j)
7949 430 continue
7950 else
7951 do 435 j=1,napx
7952 yv(1,j)=yv(1,j)+(tiltc(i)*bbiv(1,1,i)- &
7953 &tilts(i)*aaiv(1,1,i))*oidpsv(j)
7954 yv(2,j)=yv(2,j)+(tiltc(i)*aaiv(1,1,i)+ &
7955 &tilts(i)*bbiv(1,1,i))*oidpsv(j)
7956 435 continue
7957 endif
7958 goto 640
7959 !--SKEW ELEMENTS
7960 !--VERTICAL DIPOLE
7961 440 do 450 j=1,napx
7962 yv(1,j)=yv(1,j)-stracks(i)*oidpsv(j)
7963 yv(2,j)=yv(2,j)+strackc(i)*oidpsv(j)
7964 450 continue
7965 goto 640
7966 !--SKEW QUADRUPOLE
7967 460 do 470 j=1,napx
7968 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
7969 &(xv(2,j)-zsiv(1,i))*tilts(i)
7970 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
7971 &(xv(2,j)-zsiv(1,i))*tiltc(i)
7972 crkve=xlv(j)
7973 cikve=zlv(j)
7974 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
7975 &stracks(i)*crkve)
7976 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
7977 &stracks(i)*cikve)
7978 470 continue
7979 goto 640
7980 !--SKEW SEXTUPOLE
7981 480 do 490 j=1,napx
7982 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
7983 &(xv(2,j)-zsiv(1,i))*tilts(i)
7984 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
7985 &(xv(2,j)-zsiv(1,i))*tiltc(i)
7986 crkve=xlv(j)
7987 cikve=zlv(j)
7988 crkveuk=crkve*xlv(j)-cikve*zlv(j)
7989 cikve=crkve*zlv(j)+cikve*xlv(j)
7990 crkve=crkveuk
7991 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
7992 &stracks(i)*crkve)
7993 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
7994 &stracks(i)*cikve)
7995 490 continue
7996 goto 640
7997 !--SKEW OCTUPOLE
7998 500 do 510 j=1,napx
7999 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
8000 &(xv(2,j)-zsiv(1,i))*tilts(i)
8001 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
8002 &(xv(2,j)-zsiv(1,i))*tiltc(i)
8003 crkve=xlv(j)
8004 cikve=zlv(j)
8005 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8006 cikve=crkve*zlv(j)+cikve*xlv(j)
8007 crkve=crkveuk
8008 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8009 cikve=crkve*zlv(j)+cikve*xlv(j)
8010 crkve=crkveuk
8011 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
8012 &stracks(i)*crkve)
8013 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
8014 &stracks(i)*cikve)
8015 510 continue
8016 goto 640
8017 !--SKEW DECAPOLE
8018 520 do 530 j=1,napx
8019 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
8020 &(xv(2,j)-zsiv(1,i))*tilts(i)
8021 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
8022 &(xv(2,j)-zsiv(1,i))*tiltc(i)
8023 crkve=xlv(j)
8024 cikve=zlv(j)
8025 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8026 cikve=crkve*zlv(j)+cikve*xlv(j)
8027 crkve=crkveuk
8028 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8029 cikve=crkve*zlv(j)+cikve*xlv(j)
8030 crkve=crkveuk
8031 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8032 cikve=crkve*zlv(j)+cikve*xlv(j)
8033 crkve=crkveuk
8034 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
8035 &stracks(i)*crkve)
8036 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
8037 &stracks(i)*cikve)
8038 530 continue
8039 goto 640
8040 !--SKEW DODECAPOLE
8041 540 do 550 j=1,napx
8042 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
8043 &(xv(2,j)-zsiv(1,i))*tilts(i)
8044 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
8045 &(xv(2,j)-zsiv(1,i))*tiltc(i)
8046 crkve=xlv(j)
8047 cikve=zlv(j)
8048 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8049 cikve=crkve*zlv(j)+cikve*xlv(j)
8050 crkve=crkveuk
8051 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8052 cikve=crkve*zlv(j)+cikve*xlv(j)
8053 crkve=crkveuk
8054 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8055 cikve=crkve*zlv(j)+cikve*xlv(j)
8056 crkve=crkveuk
8057 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8058 cikve=crkve*zlv(j)+cikve*xlv(j)
8059 crkve=crkveuk
8060 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
8061 &stracks(i)*crkve)
8062 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
8063 &stracks(i)*cikve)
8064 550 continue
8065 goto 640
8066 !--SKEW 14-POLE
8067 560 do 570 j=1,napx
8068 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
8069 &(xv(2,j)-zsiv(1,i))*tilts(i)
8070 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
8071 &(xv(2,j)-zsiv(1,i))*tiltc(i)
8072 crkve=xlv(j)
8073 cikve=zlv(j)
8074 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8075 cikve=crkve*zlv(j)+cikve*xlv(j)
8076 crkve=crkveuk
8077 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8078 cikve=crkve*zlv(j)+cikve*xlv(j)
8079 crkve=crkveuk
8080 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8081 cikve=crkve*zlv(j)+cikve*xlv(j)
8082 crkve=crkveuk
8083 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8084 cikve=crkve*zlv(j)+cikve*xlv(j)
8085 crkve=crkveuk
8086 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8087 cikve=crkve*zlv(j)+cikve*xlv(j)
8088 crkve=crkveuk
8089 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
8090 &stracks(i)*crkve)
8091 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
8092 &stracks(i)*cikve)
8093 570 continue
8094 goto 640
8095 !--SKEW 16-POLE
8096 580 do 590 j=1,napx
8097 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
8098 &(xv(2,j)-zsiv(1,i))*tilts(i)
8099 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
8100 &(xv(2,j)-zsiv(1,i))*tiltc(i)
8101 crkve=xlv(j)
8102 cikve=zlv(j)
8103 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8104 cikve=crkve*zlv(j)+cikve*xlv(j)
8105 crkve=crkveuk
8106 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8107 cikve=crkve*zlv(j)+cikve*xlv(j)
8108 crkve=crkveuk
8109 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8110 cikve=crkve*zlv(j)+cikve*xlv(j)
8111 crkve=crkveuk
8112 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8113 cikve=crkve*zlv(j)+cikve*xlv(j)
8114 crkve=crkveuk
8115 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8116 cikve=crkve*zlv(j)+cikve*xlv(j)
8117 crkve=crkveuk
8118 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8119 cikve=crkve*zlv(j)+cikve*xlv(j)
8120 crkve=crkveuk
8121 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
8122 &stracks(i)*crkve)
8123 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
8124 &stracks(i)*cikve)
8125 590 continue
8126 goto 640
8127 !--SKEW 18-POLE
8128 600 do 610 j=1,napx
8129 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
8130 &(xv(2,j)-zsiv(1,i))*tilts(i)
8131 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
8132 &(xv(2,j)-zsiv(1,i))*tiltc(i)
8133 crkve=xlv(j)
8134 cikve=zlv(j)
8135 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8136 cikve=crkve*zlv(j)+cikve*xlv(j)
8137 crkve=crkveuk
8138 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8139 cikve=crkve*zlv(j)+cikve*xlv(j)
8140 crkve=crkveuk
8141 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8142 cikve=crkve*zlv(j)+cikve*xlv(j)
8143 crkve=crkveuk
8144 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8145 cikve=crkve*zlv(j)+cikve*xlv(j)
8146 crkve=crkveuk
8147 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8148 cikve=crkve*zlv(j)+cikve*xlv(j)
8149 crkve=crkveuk
8150 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8151 cikve=crkve*zlv(j)+cikve*xlv(j)
8152 crkve=crkveuk
8153 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8154 cikve=crkve*zlv(j)+cikve*xlv(j)
8155 crkve=crkveuk
8156 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
8157 &stracks(i)*crkve)
8158 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
8159 &stracks(i)*cikve)
8160 610 continue
8161 goto 640
8162 !--SKEW 20-POLE
8163 620 do 630 j=1,napx
8164 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
8165 &(xv(2,j)-zsiv(1,i))*tilts(i)
8166 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
8167 &(xv(2,j)-zsiv(1,i))*tiltc(i)
8168 crkve=xlv(j)
8169 cikve=zlv(j)
8170 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8171 cikve=crkve*zlv(j)+cikve*xlv(j)
8172 crkve=crkveuk
8173 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8174 cikve=crkve*zlv(j)+cikve*xlv(j)
8175 crkve=crkveuk
8176 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8177 cikve=crkve*zlv(j)+cikve*xlv(j)
8178 crkve=crkveuk
8179 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8180 cikve=crkve*zlv(j)+cikve*xlv(j)
8181 crkve=crkveuk
8182 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8183 cikve=crkve*zlv(j)+cikve*xlv(j)
8184 crkve=crkveuk
8185 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8186 cikve=crkve*zlv(j)+cikve*xlv(j)
8187 crkve=crkveuk
8188 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8189 cikve=crkve*zlv(j)+cikve*xlv(j)
8190 crkve=crkveuk
8191 crkveuk=crkve*xlv(j)-cikve*zlv(j)
8192 cikve=crkve*zlv(j)+cikve*xlv(j)
8193 crkve=crkveuk
8194 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
8195 &stracks(i)*crkve)
8196 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
8197 &stracks(i)*cikve)
8198 630 continue
8199 goto 640
8200 680 continue
8201 do 690 j=1,napx
8202 if(ibbc.eq.0) then
8203 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
8204 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
8205 else
8206 crkveb(j)= &
8207 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
8208 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
8209 cikveb(j)= &
8210 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
8211 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
8212 endif
8213 rho2b(j)=crkveb(j)*crkveb(j)+cikveb(j)*cikveb(j)
8214 if(rho2b(j).le.pieni) &
8215 &goto 690
8216 tkb(j)=rho2b(j)/(two*sigman2(1,imbb(i)))
8217 if(ibbc.eq.0) then
8218 yv(1,j)=yv(1,j)+oidpsv(j)*(strack(i)*crkveb(j)/rho2b(j)* &
8219 &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))
8220 yv(2,j)=yv(2,j)+oidpsv(j)*(strack(i)*cikveb(j)/rho2b(j)* &
8221 &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))
8222 else
8223 cccc=(strack(i)*crkveb(j)/rho2b(j)* &
8224 &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))*bbcu(imbb(i),11)- &
8225 &(strack(i)*cikveb(j)/rho2b(j)* &
8226 &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
8227 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
8228 cccc=(strack(i)*crkveb(j)/rho2b(j)* &
8229 &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))*bbcu(imbb(i),12)+ &
8230 &(strack(i)*cikveb(j)/rho2b(j)* &
8231 &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
8232 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
8233 endif
8234 690 continue
8235 goto 640
8236 700 continue
8237 if(ibtyp.eq.0) then
8238 do j=1,napx
8239 r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
8240 rb(j)=sqrt(r2b(j))
8241 rkb(j)=strack(i)*pisqrt/rb(j)
8242 if(ibbc.eq.0) then
8243 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
8244 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
8245 else
8246 crkveb(j)= &
8247 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
8248 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
8249 cikveb(j)= &
8250 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
8251 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
8252 endif
8253 xrb(j)=abs(crkveb(j))/rb(j)
8254 zrb(j)=abs(cikveb(j))/rb(j)
8255 call errf(xrb(j),zrb(j),crxb(j),crzb(j))
8256 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
8257 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
8258 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
8259 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
8260 call errf(xbb(j),zbb(j),cbxb(j),cbzb(j))
8261 if(ibbc.eq.0) then
8262 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
8263 &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
8264 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
8265 &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
8266 else
8267 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
8268 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
8269 &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
8270 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
8271 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
8272 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
8273 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
8274 &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
8275 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
8276 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
8277 endif
8278 enddo
8279 else if(ibtyp.eq.1) then
8280 do j=1,napx
8281 r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
8282 rb(j)=sqrt(r2b(j))
8283 rkb(j)=strack(i)*pisqrt/rb(j)
8284 if(ibbc.eq.0) then
8285 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
8286 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
8287 else
8288 crkveb(j)= &
8289 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
8290 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
8291 cikveb(j)= &
8292 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
8293 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
8294 endif
8295 xrb(j)=abs(crkveb(j))/rb(j)
8296 zrb(j)=abs(cikveb(j))/rb(j)
8297 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
8298 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
8299 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
8300 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
8301 enddo
8302 call wzsubv(napx,xrb(1),zrb(1),crxb(1),crzb(1))
8303 call wzsubv(napx,xbb(1),zbb(1),cbxb(1),cbzb(1))
8304 do j=1,napx
8305 if(ibbc.eq.0) then
8306 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
8307 &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
8308 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
8309 &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
8310 else
8311 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
8312 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
8313 &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
8314 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
8315 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
8316 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
8317 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
8318 &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
8319 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
8320 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
8321 endif
8322 enddo
8323 endif
8324 goto 640
8325 720 continue
8326 if(ibtyp.eq.0) then
8327 do j=1,napx
8328 r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
8329 rb(j)=sqrt(r2b(j))
8330 rkb(j)=strack(i)*pisqrt/rb(j)
8331 if(ibbc.eq.0) then
8332 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
8333 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
8334 else
8335 crkveb(j)= &
8336 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
8337 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
8338 cikveb(j)= &
8339 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
8340 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
8341 endif
8342 xrb(j)=abs(crkveb(j))/rb(j)
8343 zrb(j)=abs(cikveb(j))/rb(j)
8344 call errf(zrb(j),xrb(j),crzb(j),crxb(j))
8345 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
8346 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
8347 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
8348 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
8349 call errf(zbb(j),xbb(j),cbzb(j),cbxb(j))
8350 if(ibbc.eq.0) then
8351 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
8352 &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
8353 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
8354 &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
8355 else
8356 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
8357 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
8358 &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
8359 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
8360 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
8361 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
8362 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
8363 &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
8364 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
8365 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
8366 endif
8367 enddo
8368 else if(ibtyp.eq.1) then
8369 do j=1,napx
8370 r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
8371 rb(j)=sqrt(r2b(j))
8372 rkb(j)=strack(i)*pisqrt/rb(j)
8373 if(ibbc.eq.0) then
8374 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
8375 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
8376 else
8377 crkveb(j)= &
8378 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
8379 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
8380 cikveb(j)= &
8381 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
8382 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
8383 endif
8384 xrb(j)=abs(crkveb(j))/rb(j)
8385 zrb(j)=abs(cikveb(j))/rb(j)
8386 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
8387 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
8388 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
8389 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
8390 enddo
8391 call wzsubv(napx,zrb(1),xrb(1),crzb(1),crxb(1))
8392 call wzsubv(napx,zbb(1),xbb(1),cbzb(1),cbxb(1))
8393 do j=1,napx
8394 if(ibbc.eq.0) then
8395 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
8396 &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
8397 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
8398 &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
8399 else
8400 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
8401 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
8402 &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
8403 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
8404 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
8405 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
8406 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
8407 &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
8408 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
8409 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
8410 endif
8411 enddo
8412 endif
8413 goto 640
8414 730 continue
8415 !--Hirata's 6D beam-beam kick
8416 do j=1,napx
8417 track6d(1,j)=(xv(1,j)+ed(ix)-clobeam(1,imbb(i)))*c1m3
8418 track6d(2,j)=(yv(1,j)/oidpsv(j)-clobeam(4,imbb(i)))*c1m3
8419 track6d(3,j)=(xv(2,j)+ek(ix)-clobeam(2,imbb(i)))*c1m3
8420 track6d(4,j)=(yv(2,j)/oidpsv(j)-clobeam(5,imbb(i)))*c1m3
8421 track6d(5,j)=(sigmv(j)-clobeam(3,imbb(i)))*c1m3
8422 track6d(6,j)=dpsv(j)-clobeam(6,imbb(i))
8423 enddo
8424 call beamint(napx,track6d,parbe,sigz,bbcu,imbb(i),ix,ibtyp, &
8425 &ibbc)
8426 do j=1,napx
8427 xv(1,j)=track6d(1,j)*c1e3+clobeam(1,imbb(i))- &
8428 &beamoff(1,imbb(i))
8429 xv(2,j)=track6d(3,j)*c1e3+clobeam(2,imbb(i))- &
8430 &beamoff(2,imbb(i))
8431 dpsv(j)=track6d(6,j)+clobeam(6,imbb(i))-beamoff(6,imbb(i))
8432 oidpsv(j)=one/(one+dpsv(j))
8433 yv(1,j)=(track6d(2,j)*c1e3+clobeam(4,imbb(i))- &
8434 &beamoff(4,imbb(i)))*oidpsv(j)
8435 yv(2,j)=(track6d(4,j)*c1e3+clobeam(5,imbb(i))- &
8436 &beamoff(5,imbb(i)))*oidpsv(j)
8437 ejfv(j)=dpsv(j)*e0f+e0f
8438 ejv(j)=sqrt(ejfv(j)*ejfv(j)+pma*pma)
8439 rvv(j)=(ejv(j)*e0f)/(e0*ejfv(j))
8440 if(ithick.eq.1) call envarsv(dpsv,oidpsv,rvv,ekv)
8441 enddo
8442 goto 640
8443 740 continue
8444 irrtr=imtr(ix)
8445 do j=1,napx
8446 sigmv(j)=sigmv(j)+cotr(irrtr,5)+rrtr(irrtr,5,1)*xv(1,j)+ &
8447 &rrtr(irrtr,5,2)*yv(1,j)+rrtr(irrtr,5,3)*xv(2,j)+ &
8448 &rrtr(irrtr,5,4)*yv(2,j)
8449 pux=xv(1,j)
8450 dpsv3(j)=dpsv(j)*c1e3
8451 xv(1,j)=cotr(irrtr,1)+rrtr(irrtr,1,1)*pux+ &
8452 &rrtr(irrtr,1,2)*yv(1,j)+idz(1)*dpsv3(j)*rrtr(irrtr,1,6)
8453 yv(1,j)=cotr(irrtr,2)+rrtr(irrtr,2,1)*pux+ &
8454 &rrtr(irrtr,2,2)*yv(1,j)+idz(1)*dpsv3(j)*rrtr(irrtr,2,6)
8455 pux=xv(2,j)
8456 xv(2,j)=cotr(irrtr,3)+rrtr(irrtr,3,3)*pux+ &
8457 &rrtr(irrtr,3,4)*yv(2,j)+idz(2)*dpsv3(j)*rrtr(irrtr,3,6)
8458 yv(2,j)=cotr(irrtr,4)+rrtr(irrtr,4,3)*pux+ &
8459 &rrtr(irrtr,4,4)*yv(2,j)+idz(2)*dpsv3(j)*rrtr(irrtr,4,6)
8460 enddo
8461
8462 !----------------------------------------------------------------------
8463
8464 ! Wire.
8465
8466 goto 640
8467 745 continue
8468 xory=1
8469 nfree=nturn1(ix)
8470 if(n.gt.nfree) then
8471 nac=n-nfree
8472 pi=4d0*atan(1d0)
8473 !---------ACdipAmp input in Tesla*meter converted to KeV/c
8474 !---------ejfv(j) should be in MeV/c --> ACdipAmp/ejfv(j) is in mrad
8475 acdipamp=ed(ix)*clight*1.0d-3
8476 !---------Qd input in tune units
8477 qd=ek(ix)
8478 !---------ACphase input in radians
8479 acphase=acdipph(ix)
8480 nramp1=nturn2(ix)
8481 nplato=nturn3(ix)
8482 nramp2=nturn4(ix)
8483 do j=1,napx
8484 if (xory.eq.1) then
8485 acdipamp2=acdipamp*tilts(i)
8486 acdipamp1=acdipamp*tiltc(i)
8487 else
8488 acdipamp2=acdipamp*tiltc(i)
8489 acdipamp1=-acdipamp*tilts(i)
8490 endif
8491 if(nramp1.gt.nac) then
8492 yv(1,j)=yv(1,j)+acdipamp1* &
8493 &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
8494 yv(2,j)=yv(2,j)+acdipamp2* &
8495 &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
8496 endif
8497 if(nac.ge.nramp1.and.(nramp1+nplato).gt.nac) then
8498 yv(1,j)=yv(1,j)+acdipamp1* &
8499 &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
8500 yv(2,j)=yv(2,j)+acdipamp2* &
8501 &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
8502 endif
8503 if(nac.ge.(nramp1+nplato).and.(nramp2+nramp1+nplato).gt. &
8504 &nac)then
8505 yv(1,j)=yv(1,j)+acdipamp1*sin(2d0*pi*qd*nac+acphase)* &
8506 &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
8507 yv(2,j)=yv(2,j)+acdipamp2*sin(2d0*pi*qd*nac+acphase)* &
8508 &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
8509 endif
8510 enddo
8511 endif
8512 goto 640
8513 746 continue
8514 xory=2
8515 nfree=nturn1(ix)
8516 if(n.gt.nfree) then
8517 nac=n-nfree
8518 pi=4d0*atan(1d0)
8519 !---------ACdipAmp input in Tesla*meter converted to KeV/c
8520 !---------ejfv(j) should be in MeV/c --> ACdipAmp/ejfv(j) is in mrad
8521 acdipamp=ed(ix)*clight*1.0d-3
8522 !---------Qd input in tune units
8523 qd=ek(ix)
8524 !---------ACphase input in radians
8525 acphase=acdipph(ix)
8526 nramp1=nturn2(ix)
8527 nplato=nturn3(ix)
8528 nramp2=nturn4(ix)
8529 do j=1,napx
8530 if (xory.eq.1) then
8531 acdipamp2=acdipamp*tilts(i)
8532 acdipamp1=acdipamp*tiltc(i)
8533 else
8534 acdipamp2=acdipamp*tiltc(i)
8535 acdipamp1=-acdipamp*tilts(i)
8536 endif
8537 if(nramp1.gt.nac) then
8538 yv(1,j)=yv(1,j)+acdipamp1* &
8539 &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
8540 yv(2,j)=yv(2,j)+acdipamp2* &
8541 &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
8542 endif
8543 if(nac.ge.nramp1.and.(nramp1+nplato).gt.nac) then
8544 yv(1,j)=yv(1,j)+acdipamp1* &
8545 &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
8546 yv(2,j)=yv(2,j)+acdipamp2* &
8547 &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
8548 endif
8549 if(nac.ge.(nramp1+nplato).and.(nramp2+nramp1+nplato).gt. &
8550 &nac)then
8551 yv(1,j)=yv(1,j)+acdipamp1*sin(2d0*pi*qd*nac+acphase)* &
8552 &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
8553 yv(2,j)=yv(2,j)+acdipamp2*sin(2d0*pi*qd*nac+acphase)* &
8554 &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
8555 endif
8556 enddo
8557 endif
8558 goto 640
8559
8560 !----------------------------
8561
8562 ! Wire.
8563
8564 748 continue
8565 ! magnetic rigidity
8566 chi = sqrt(e0*e0-pmap*pmap)*c1e6/clight
8567
8568 ix = ixcav
8569 tx = xrms(ix)
8570 ty = zrms(ix)
8571 dx = xpl(ix)
8572 dy = zpl(ix)
8573 embl = ek(ix)
8574 l = wirel(ix)
8575 cur = ed(ix)
8576
8577 leff = embl/cos(tx)/cos(ty)
8578 rx = dx *cos(tx)-embl*sin(tx)/2
8579 lin= dx *sin(tx)+embl*cos(tx)/2
8580 ry = dy *cos(ty)-lin *sin(ty)
8581 lin= lin*cos(ty)+dy *sin(ty)
8582
8583 do 750 j=1, napx
8584
8585 xv(1,j) = xv(1,j) * c1m3
8586 xv(2,j) = xv(2,j) * c1m3
8587 yv(1,j) = yv(1,j) * c1m3
8588 yv(2,j) = yv(2,j) * c1m3
8589
8590 ! print *, 'Start: ',j,xv(1,j),xv(2,j),yv(1,j),
8591 ! &yv(2,j)
8592
8593 ! call drift(-embl/2)
8594
8595 xv(1,j) = xv(1,j) - embl/2*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
8596 &yv(2,j)**2)
8597 xv(2,j) = xv(2,j) - embl/2*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
8598 &yv(2,j)**2)
8599
8600 ! call tilt(tx,ty)
8601
8602 xv(2,j) = xv(2,j)-xv(1,j)*sin(tx)*yv(2,j)/sqrt((1+dpsv(j))**2- &
8603 &yv(2,j)**2)/cos(atan(yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
8604 &yv(2,j)**2))-tx)
8605 xv(1,j) = xv(1,j)*(cos(tx)-sin(tx)*tan(atan(yv(1,j)/ &
8606 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-tx))
8607 yv(1,j) = sqrt((1+dpsv(j))**2-yv(2,j)**2)*sin(atan(yv(1,j)/ &
8608 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-tx)
8609
8610 xv(1,j) = xv(1,j)-xv(2,j)*sin(ty)*yv(1,j)/sqrt((1+dpsv(j))**2- &
8611 &yv(1,j)**2)/cos(atan(yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
8612 &yv(2,j)**2))-ty)
8613 xv(2,j) = xv(2,j)*(cos(ty)-sin(ty)*tan(atan(yv(2,j)/ &
8614 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-ty))
8615 yv(2,j) = sqrt((1+dpsv(j))**2-yv(1,j)**2)*sin(atan(yv(2,j)/ &
8616 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-ty)
8617
8618 ! call drift(lin)
8619
8620 xv(1,j) = xv(1,j) + lin*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
8621 &yv(2,j)**2)
8622 xv(2,j) = xv(2,j) + lin*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
8623 &yv(2,j)**2)
8624
8625 ! call kick(l,cur,lin,rx,ry,chi)
8626
8627 xi = xv(1,j)-rx
8628 yi = xv(2,j)-ry
8629 yv(1,j) = yv(1,j)-1.0d-7*cur/chi*xi/(xi**2+yi**2)* &
8630 &(sqrt((lin+l)**2+xi**2+yi**2)-sqrt((lin-l)**2+ &
8631 &xi**2+yi**2))
8632 !GRD FOR CONSISTENSY
8633 ! yv(2,j) = yv(2,j)-1e-7*cur/chi*yi/(xi**2+yi**2)* &
8634 yv(2,j) = yv(2,j)-1.0d-7*cur/chi*yi/(xi**2+yi**2)* &
8635 &(sqrt((lin+l)**2+xi**2+yi**2)-sqrt((lin-l)**2+ &
8636 &xi**2+yi**2))
8637
8638 ! call drift(leff-lin)
8639
8640 xv(1,j) = xv(1,j) + (leff-lin)*yv(1,j)/sqrt((1+dpsv(j))**2- &
8641 &yv(1,j)**2-yv(2,j)**2)
8642 xv(2,j) = xv(2,j) + (leff-lin)*yv(2,j)/sqrt((1+dpsv(j))**2- &
8643 &yv(1,j)**2-yv(2,j)**2)
8644
8645 ! call invtilt(tx,ty)
8646
8647 xv(1,j) = xv(1,j)-xv(2,j)*sin(-ty)*yv(1,j)/sqrt((1+dpsv(j))**2- &
8648 &yv(1,j)**2)/cos(atan(yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
8649 &yv(2,j)**2))+ty)
8650 xv(2,j) = xv(2,j)*(cos(-ty)-sin(-ty)*tan(atan(yv(2,j)/ &
8651 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+ty))
8652 yv(2,j) = sqrt((1+dpsv(j))**2-yv(1,j)**2)*sin(atan(yv(2,j)/ &
8653 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+ty)
8654
8655 xv(2,j) = xv(2,j)-xv(1,j)*sin(-tx)*yv(2,j)/sqrt((1+dpsv(j))**2- &
8656 &yv(2,j)**2)/cos(atan(yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
8657 &yv(2,j)**2))+tx)
8658 xv(1,j) = xv(1,j)*(cos(-tx)-sin(-tx)*tan(atan(yv(1,j)/ &
8659 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+tx))
8660 yv(1,j) = sqrt((1+dpsv(j))**2-yv(2,j)**2)*sin(atan(yv(1,j)/ &
8661 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+tx)
8662
8663 ! call shift(-embl*tan(tx),-embl*tan(ty)/cos(tx))
8664
8665 xv(1,j) = xv(1,j) + embl*tan(tx)
8666 xv(2,j) = xv(2,j) + embl*tan(ty)/cos(tx)
8667
8668 ! call drift(-embl/2)
8669
8670 xv(1,j) = xv(1,j) - embl/2*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
8671 &yv(2,j)**2)
8672 xv(2,j) = xv(2,j) - embl/2*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
8673 &yv(2,j)**2)
8674
8675 xv(1,j) = xv(1,j) * c1e3
8676 xv(2,j) = xv(2,j) * c1e3
8677 yv(1,j) = yv(1,j) * c1e3
8678 yv(2,j) = yv(2,j) * c1e3
8679
8680 ! print *, 'End: ',j,xv(1,j),xv(2,j),yv(1,j),
8681 ! &yv(2,j)
8682
8683 !-----------------------------------------------------------------------
8684
8685 750 continue
8686 goto 640
8687
8688 !----------------------------
8689
8690 640 continue
8691 llost=.false.
8692 do j=1,napx
8693 llost=llost.or. &
8694 &abs(xv(1,j)).gt.aper(1).or.abs(xv(2,j)).gt.aper(2)
8695 enddo
8696 if (llost) then
8697 kpz=abs(kp(ix))
8698 if(kpz.eq.2) then
8699 call lostpar3(i,ix,nthinerr)
8700 if(nthinerr.ne.0) return
8701 elseif(kpz.eq.3) then
8702 call lostpar4(i,ix,nthinerr)
8703 if(nthinerr.ne.0) return
8704 else
8705 call lostpar2(i,ix,nthinerr)
8706 if(nthinerr.ne.0) return
8707 endif
8708 endif
8709 650 continue
8710 call lostpart(nthinerr)
8711 if(nthinerr.ne.0) return
8712 if(ntwin.ne.2) call dist1
8713 if(mod(n,nwr(4)).eq.0) call write6(n)
8714 660 continue
8715 return
8716 end
8717 subroutine ripple(n)
8718 !-----------------------------------------------------------------------
8719 !
8720 ! F. SCHMIDT
8721 !-----------------------------------------------------------------------
8722 implicit none
8723 integer i,n,nripple
8724 integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1, &
8725 &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran, &
8726 &nrco,ntr,nzfz
8727 parameter(npart = 64,nmac = 1)
8728 parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000, &
8729 &nzfz = 300000,mmul = 11)
8730 parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5, &
8731 &nema = 15)
8732 parameter(mcor = 10,mcop = mcor+6, mbea = 15)
8733 parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
8734 parameter(nmon1 = 600,ncor1 = 600)
8735 parameter(ntr = 20,nbb = 160)
8736 double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3, &
8737 &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21, &
8738 &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
8739 &one,pieni,pmae,pmap,three,two,zero
8740 parameter(pieni = 1d-38)
8741 parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
8742 parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
8743 parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
8744 parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
8745 parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 = &
8746 &1.0d16)
8747 parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
8748 parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
8749 parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
8750 parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
8751 parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
8752 parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
8753 parameter(pmap = 938.271998d0,pmae = .510998902d0)
8754 parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
8755 integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo, &
8756 &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor, &
8757 &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb, &
8758 &imc,imtr,iorg,iout, &
8759 &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires, &
8760 &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw, &
8761 &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox, &
8762 &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo, &
8763 &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx, &
8764 &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr, &
8765 &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew, &
8766 &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr, &
8767 &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
8768 double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu, &
8769 &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
8770 &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft, &
8771 &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
8772 &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign, &
8773 &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum, &
8774 &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
8775 &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph, &
8776 &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
8777 &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel, &
8778 &acdipph
8779 real hmal
8780 character*16 bez,bezb,bezr,erbez,bezl
8781 character*80 toptit,sixtit,commen
8782 common/erro/ierro,erbez
8783 common/kons/pi,pi2,pisqrt,rad
8784 common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
8785 common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
8786 common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
8787 common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
8788 common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
8789 common/syos2/rvf(mpa)
8790 common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
8791 &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
8792 common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3), &
8793 &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen, &
8794 &iicav,itionc(nele),ition,idp,ncy,ixcav
8795 common/corcom/dpscor,sigcor,icode,idam,its6d
8796 common/multi/bk0(nele,mmul),ak0(nele,mmul), &
8797 &bka(nele,mmul),aka(nele,mmul)
8798 common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
8799 common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
8800 common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz), &
8801 &tilts(nblz),mout2,icext(nblz),icextal(nblz)
8802 common/beo /aper(2),di0(2),dip0(2),ta(6,6)
8803 common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
8804 &iout
8805 common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
8806 common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint, &
8807 &ntco,eui,euii,nlin,bezl(nele)
8808 common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2), &
8809 &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr, &
8810 &ncororb(nele)
8811 common/apert/apx(nele),apz(nele),ape(3,nele)
8812 common/clos/sigma0(2),iclo,ncorru,ncorrep
8813 common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20), &
8814 &ratioe(nele),iratioe(nele),icoe
8815 common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
8816 common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
8817 common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
8818 common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
8819 common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2, &
8820 &nstart,nstop,iskip,iconv,imad
8821 common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
8822 common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
8823 common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
8824 common/ripp2/nrturn
8825 common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
8826 common/pawc/hmal(nplo)
8827 common/tit/sixtit,commen,ithick
8828 common/co6d/clo6(3),clop6(3)
8829 common/dkic/dki(nele,3)
8830 common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb), &
8831 &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart), &
8832 &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar, &
8833 &nbeam,ibbc,ibeco,ibtyp,lhc
8834 common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
8835 common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
8836 common/wireco/ wirel(nele)
8837 common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele), &
8838 &nturn3(nele), nturn4(nele)
8839 integer idz,itra
8840 double precision al,as,chi0,chid,dp1,dps,exz,sigm
8841 common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa), &
8842 &dps(mpa),idz(2)
8843 common/anf/chi0,chid,exz(2,6),dp1,itra
8844 integer ichrom,is
8845 double precision alf0,amp,bet0,clo,clop,cro,x,y
8846 common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
8847 common/chrom/cro(2),is(2),ichrom
8848 integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
8849 &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
8850 double precision dpmax,preda,weig1,weig2
8851 character*16 coel
8852 common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
8853 common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
8854 common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
8855 &coel(10)
8856 double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
8857 &zsi
8858 real tlim,time0,time1
8859 common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz), &
8860 &aai(nblz,mmul),bbi(nblz,mmul)
8861 common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
8862 common/damp/damp,ampt
8863 common/ttime/tlim,time0,time1
8864 double precision tasm
8865 common/tasm/tasm(6,6)
8866 integer iv,ixv,nlostp,nms,numxv
8867 double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
8868 &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
8869 &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl, &
8870 &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
8871 &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv, &
8872 &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas, &
8873 &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
8874 &zsiv,zsv
8875 logical pstop
8876 common/main1/ &
8877 &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz), &
8878 &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz), &
8879 &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2), &
8880 &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart), &
8881 &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart), &
8882 &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart), &
8883 &xlv(npart),zlv(npart),pstop(npart),rvv(npart), &
8884 &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
8885 common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart), &
8886 &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart), &
8887 &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart), &
8888 &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart), &
8889 &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart), &
8890 &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
8891 &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
8892 &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart), &
8893 &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
8894 common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo), &
8895 &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart), &
8896 &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6), &
8897 &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
8898 integer numx
8899 double precision e0f
8900 common/main4/ e0f,numx
8901 integer ktrack,nwri
8902 double precision dpsv1,strack,strackc,stracks
8903 common/track/ ktrack(nblz),strack(nblz),strackc(nblz), &
8904 &stracks(nblz),dpsv1(npart),nwri
8905 save
8906 !-----------------------------------------------------------------------
8907 nripple=nrturn+n
8908 do 20 i=1,iu
8909 if(abs(rsmi(i)).gt.pieni) then
8910 smiv(1,i)=rsmi(i)*cos(two*pi*(nripple-1)/rfres(i)+rzphs(i))
8911 strack(i)=smiv(1,i)
8912 strackc(i)=strack(i)*tiltc(i)
8913 stracks(i)=strack(i)*tilts(i)
8914 endif
8915 20 continue
8916 return
8917 end
8918 subroutine writebin(nthinerr)
8919 !-----------------------------------------------------------------------
8920 !
8921 ! F. SCHMIDT
8922 !-----------------------------------------------------------------------
8923 ! 3 February 1999
8924 !-----------------------------------------------------------------------
8925 implicit none
8926 integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1, &
8927 &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran, &
8928 &nrco,ntr,nzfz
8929 parameter(npart = 64,nmac = 1)
8930 parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000, &
8931 &nzfz = 300000,mmul = 11)
8932 parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5, &
8933 &nema = 15)
8934 parameter(mcor = 10,mcop = mcor+6, mbea = 15)
8935 parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
8936 parameter(nmon1 = 600,ncor1 = 600)
8937 parameter(ntr = 20,nbb = 160)
8938 double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3, &
8939 &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21, &
8940 &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
8941 &one,pieni,pmae,pmap,three,two,zero
8942 parameter(pieni = 1d-38)
8943 parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
8944 parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
8945 parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
8946 parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
8947 parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 = &
8948 &1.0d16)
8949 parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
8950 parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
8951 parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
8952 parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
8953 parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
8954 parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
8955 parameter(pmap = 938.271998d0,pmae = .510998902d0)
8956 parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
8957 integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo, &
8958 &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor, &
8959 &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb, &
8960 &imc,imtr,iorg,iout, &
8961 &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires, &
8962 &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw, &
8963 &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox, &
8964 &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo, &
8965 &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx, &
8966 &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr, &
8967 &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew, &
8968 &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr, &
8969 &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
8970 double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu, &
8971 &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
8972 &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft, &
8973 &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
8974 &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign, &
8975 &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum, &
8976 &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
8977 &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph, &
8978 &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
8979 &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel, &
8980 &acdipph
8981 real hmal
8982 character*16 bez,bezb,bezr,erbez,bezl
8983 character*80 toptit,sixtit,commen
8984 common/erro/ierro,erbez
8985 common/kons/pi,pi2,pisqrt,rad
8986 common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
8987 common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
8988 common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
8989 common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
8990 common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
8991 common/syos2/rvf(mpa)
8992 common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
8993 &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
8994 common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3), &
8995 &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen, &
8996 &iicav,itionc(nele),ition,idp,ncy,ixcav
8997 common/corcom/dpscor,sigcor,icode,idam,its6d
8998 common/multi/bk0(nele,mmul),ak0(nele,mmul), &
8999 &bka(nele,mmul),aka(nele,mmul)
9000 common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
9001 common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
9002 common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz), &
9003 &tilts(nblz),mout2,icext(nblz),icextal(nblz)
9004 common/beo /aper(2),di0(2),dip0(2),ta(6,6)
9005 common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
9006 &iout
9007 common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
9008 common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint, &
9009 &ntco,eui,euii,nlin,bezl(nele)
9010 common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2), &
9011 &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr, &
9012 &ncororb(nele)
9013 common/apert/apx(nele),apz(nele),ape(3,nele)
9014 common/clos/sigma0(2),iclo,ncorru,ncorrep
9015 common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20), &
9016 &ratioe(nele),iratioe(nele),icoe
9017 common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
9018 common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
9019 common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
9020 common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
9021 common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2, &
9022 &nstart,nstop,iskip,iconv,imad
9023 common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
9024 common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
9025 common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
9026 common/ripp2/nrturn
9027 common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
9028 common/pawc/hmal(nplo)
9029 common/tit/sixtit,commen,ithick
9030 common/co6d/clo6(3),clop6(3)
9031 common/dkic/dki(nele,3)
9032 common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb), &
9033 &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart), &
9034 &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar, &
9035 &nbeam,ibbc,ibeco,ibtyp,lhc
9036 common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
9037 common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
9038 common/wireco/ wirel(nele)
9039 common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele), &
9040 &nturn3(nele), nturn4(nele)
9041 integer idz,itra
9042 double precision al,as,chi0,chid,dp1,dps,exz,sigm
9043 common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa), &
9044 &dps(mpa),idz(2)
9045 common/anf/chi0,chid,exz(2,6),dp1,itra
9046 integer ichrom,is
9047 double precision alf0,amp,bet0,clo,clop,cro,x,y
9048 common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
9049 common/chrom/cro(2),is(2),ichrom
9050 integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
9051 &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
9052 double precision dpmax,preda,weig1,weig2
9053 character*16 coel
9054 common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
9055 common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
9056 common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
9057 &coel(10)
9058 double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
9059 &zsi
9060 real tlim,time0,time1
9061 common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz), &
9062 &aai(nblz,mmul),bbi(nblz,mmul)
9063 common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
9064 common/damp/damp,ampt
9065 common/ttime/tlim,time0,time1
9066 double precision tasm
9067 common/tasm/tasm(6,6)
9068 integer iv,ixv,nlostp,nms,numxv
9069 double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
9070 &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
9071 &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl, &
9072 &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
9073 &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv, &
9074 &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas, &
9075 &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
9076 &zsiv,zsv
9077 logical pstop
9078 common/main1/ &
9079 &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz), &
9080 &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz), &
9081 &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2), &
9082 &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart), &
9083 &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart), &
9084 &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart), &
9085 &xlv(npart),zlv(npart),pstop(npart),rvv(npart), &
9086 &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
9087 common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart), &
9088 &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart), &
9089 &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart), &
9090 &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart), &
9091 &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart), &
9092 &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
9093 &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
9094 &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart), &
9095 &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
9096 common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo), &
9097 &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart), &
9098 &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6), &
9099 &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
9100 integer numx
9101 double precision e0f
9102 common/main4/ e0f,numx
9103 integer ktrack,nwri
9104 double precision dpsv1,strack,strackc,stracks
9105 common/track/ ktrack(nblz),strack(nblz),strackc(nblz), &
9106 &stracks(nblz),dpsv1(npart),nwri
9107 integer ia,ia2,ie,nthinerr
9108 save
9109 !-----------------------------------------------------------------------
9110 !GRD do 10 ia=1,napx
9111 do 10 ia=1,napx-1
9112 !GRD
9113 if(.not.pstop(nlostp(ia)).and..not.pstop(nlostp(ia)+1).and. &
9114 &(mod(nlostp(ia),2).ne.0)) then
9115 ia2=(nlostp(ia)+1)/2
9116 ie=ia+1
9117 if(ntwin.ne.2) then
9118 write(91-ia2,iostat=ierro) &
9119 &numx,nlostp(ia),dam(ia), &
9120 &xv(1,ia),yv(1,ia),xv(2,ia),yv(2,ia),sigmv(ia),dpsv(ia),e0
9121 endfile 91-ia2
9122 backspace 91-ia2
9123 else
9124 write(91-ia2,iostat=ierro) &
9125 &numx,nlostp(ia),dam(ia), &
9126 &xv(1,ia),yv(1,ia),xv(2,ia),yv(2,ia),sigmv(ia),dpsv(ia),e0, &
9127 &nlostp(ia)+1,dam(ia), &
9128 &xv(1,ie),yv(1,ie),xv(2,ie),yv(2,ie),sigmv(ie),dpsv(ie),e0
9129 endfile 91-ia2
9130 backspace 91-ia2
9131 endif
9132 if(ierro.ne.0) then
9133 write(*,*)
9134 write(*,*) '*** ERROR ***,PROBLEMS WRITING TO FILE # : ', &
9135 &91-ia2
9136 write(*,*) 'ERROR CODE : ',ierro
9137 write(*,*)
9138 endfile 12
9139 backspace 12
9140 nthinerr=3000
9141 return
9142 endif
9143 endif
9144 10 continue
9145 return
9146 end
9147 subroutine lostpart(nthinerr)
9148 !-----------------------------------------------------------------------
9149 !
9150 ! F. SCHMIDT
9151 !-----------------------------------------------------------------------
9152 ! 3 February 1999
9153 !-----------------------------------------------------------------------
9154 implicit none
9155 ! logical isnan
9156 logical myisnan
9157 integer ib2,ib3,ilostch,j,jj,jj1,lnapx,nthinerr
9158 integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1, &
9159 &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran, &
9160 &nrco,ntr,nzfz
9161 parameter(npart = 64,nmac = 1)
9162 parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000, &
9163 &nzfz = 300000,mmul = 11)
9164 parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5, &
9165 &nema = 15)
9166 parameter(mcor = 10,mcop = mcor+6, mbea = 15)
9167 parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
9168 parameter(nmon1 = 600,ncor1 = 600)
9169 parameter(ntr = 20,nbb = 160)
9170 double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3, &
9171 &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21, &
9172 &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
9173 &one,pieni,pmae,pmap,three,two,zero
9174 parameter(pieni = 1d-38)
9175 parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
9176 parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
9177 parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
9178 parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
9179 parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 = &
9180 &1.0d16)
9181 parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
9182 parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
9183 parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
9184 parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
9185 parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
9186 parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
9187 parameter(pmap = 938.271998d0,pmae = .510998902d0)
9188 parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
9189 integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo, &
9190 &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor, &
9191 &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb, &
9192 &imc,imtr,iorg,iout, &
9193 &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires, &
9194 &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw, &
9195 &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox, &
9196 &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo, &
9197 &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx, &
9198 &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr, &
9199 &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew, &
9200 &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr, &
9201 &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
9202 double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu, &
9203 &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
9204 &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft, &
9205 &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
9206 &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign, &
9207 &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum, &
9208 &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
9209 &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph, &
9210 &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
9211 &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel, &
9212 &acdipph
9213 real hmal
9214 character*16 bez,bezb,bezr,erbez,bezl
9215 character*80 toptit,sixtit,commen
9216 common/erro/ierro,erbez
9217 common/kons/pi,pi2,pisqrt,rad
9218 common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
9219 common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
9220 common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
9221 common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
9222 common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
9223 common/syos2/rvf(mpa)
9224 common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
9225 &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
9226 common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3), &
9227 &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen, &
9228 &iicav,itionc(nele),ition,idp,ncy,ixcav
9229 common/corcom/dpscor,sigcor,icode,idam,its6d
9230 common/multi/bk0(nele,mmul),ak0(nele,mmul), &
9231 &bka(nele,mmul),aka(nele,mmul)
9232 common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
9233 common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
9234 common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz), &
9235 &tilts(nblz),mout2,icext(nblz),icextal(nblz)
9236 common/beo /aper(2),di0(2),dip0(2),ta(6,6)
9237 common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
9238 &iout
9239 common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
9240 common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint, &
9241 &ntco,eui,euii,nlin,bezl(nele)
9242 common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2), &
9243 &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr, &
9244 &ncororb(nele)
9245 common/apert/apx(nele),apz(nele),ape(3,nele)
9246 common/clos/sigma0(2),iclo,ncorru,ncorrep
9247 common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20), &
9248 &ratioe(nele),iratioe(nele),icoe
9249 common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
9250 common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
9251 common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
9252 common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
9253 common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2, &
9254 &nstart,nstop,iskip,iconv,imad
9255 common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
9256 common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
9257 common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
9258 common/ripp2/nrturn
9259 common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
9260 common/pawc/hmal(nplo)
9261 common/tit/sixtit,commen,ithick
9262 common/co6d/clo6(3),clop6(3)
9263 common/dkic/dki(nele,3)
9264 common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb), &
9265 &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart), &
9266 &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar, &
9267 &nbeam,ibbc,ibeco,ibtyp,lhc
9268 common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
9269 common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
9270 common/wireco/ wirel(nele)
9271 common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele), &
9272 &nturn3(nele), nturn4(nele)
9273 integer nnumxv
9274 common/postr2/nnumxv(npart)
9275 integer idz,itra
9276 double precision al,as,chi0,chid,dp1,dps,exz,sigm
9277 common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa), &
9278 &dps(mpa),idz(2)
9279 common/anf/chi0,chid,exz(2,6),dp1,itra
9280 integer ichrom,is
9281 double precision alf0,amp,bet0,clo,clop,cro,x,y
9282 common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
9283 common/chrom/cro(2),is(2),ichrom
9284 integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
9285 &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
9286 double precision dpmax,preda,weig1,weig2
9287 character*16 coel
9288 common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
9289 common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
9290 common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
9291 &coel(10)
9292 double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
9293 &zsi
9294 real tlim,time0,time1
9295 common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz), &
9296 &aai(nblz,mmul),bbi(nblz,mmul)
9297 common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
9298 common/damp/damp,ampt
9299 common/ttime/tlim,time0,time1
9300 double precision tasm
9301 common/tasm/tasm(6,6)
9302 integer iv,ixv,nlostp,nms,numxv
9303 double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
9304 &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
9305 &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl, &
9306 &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
9307 &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv, &
9308 &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas, &
9309 &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
9310 &zsiv,zsv
9311 logical pstop
9312 common/main1/ &
9313 &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz), &
9314 &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz), &
9315 &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2), &
9316 &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart), &
9317 &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart), &
9318 &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart), &
9319 &xlv(npart),zlv(npart),pstop(npart),rvv(npart), &
9320 &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
9321 common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart), &
9322 &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart), &
9323 &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart), &
9324 &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart), &
9325 &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart), &
9326 &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
9327 &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
9328 &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart), &
9329 &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
9330 common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo), &
9331 &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart), &
9332 &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6), &
9333 &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
9334 integer numx
9335 double precision e0f
9336 common/main4/ e0f,numx
9337 integer ktrack,nwri
9338 double precision dpsv1,strack,strackc,stracks
9339 common/track/ ktrack(nblz),strack(nblz),strackc(nblz), &
9340 &stracks(nblz),dpsv1(npart),nwri
9341 save
9342 !-----------------------------------------------------------------------
9343 ilostch=0
9344 do 10 j=1,napx
9345 if(abs(xv(1,j)).gt.aper(1).or.abs(xv(2,j)).gt.aper(2).or. &
9346 ! &isnan(xv(1,j),xv(1,j)).or.isnan(xv(2,j),xv(2,j))) then
9347 &myisnan(xv(1,j),xv(1,j)).or.myisnan(xv(2,j),xv(2,j))) then
9348 ilostch=1
9349 pstop(nlostp(j))=.true.
9350 endif
9351 10 continue
9352 do 20 j=1,napx
9353 if(pstop(nlostp(j))) then
9354 aperv(nlostp(j),1)=aper(1)
9355 aperv(nlostp(j),2)=aper(2)
9356 xvl(1,nlostp(j))=xv(1,j)
9357 xvl(2,nlostp(j))=xv(2,j)
9358 yvl(1,nlostp(j))=yv(1,j)
9359 yvl(2,nlostp(j))=yv(2,j)
9360 dpsvl(nlostp(j))=dpsv(j)
9361 ejvl(nlostp(j))=ejv(j)
9362 sigmvl(nlostp(j))=sigmv(j)
9363 numxv(nlostp(j))=numx
9364 nnumxv(nlostp(j))=numx
9365 if(mod(nlostp(j),2).eq.one) then
9366 write(*,10000) nlostp(j),nms(nlostp(j))*izu0, &
9367 &dp0v(nlostp(j)),numxv(nlostp(j)),abs(xvl(1,nlostp(j))), &
9368 &aperv(nlostp(j),1),abs(xvl(2,nlostp(j))), &
9369 &aperv(nlostp(j),2)
9370 else
9371 write(*,10000) nlostp(j),nms(nlostp(j)-1)*izu0, &
9372 &dp0v(nlostp(j)-1),numxv(nlostp(j)),abs(xvl(1,nlostp(j))), &
9373 &aperv(nlostp(j),1),abs(xvl(2,nlostp(j))), &
9374 &aperv(nlostp(j),2)
9375 endif
9376 endif
9377 20 continue
9378 lnapx=napx
9379 do 30 j=napx,1,-1
9380 if(pstop(nlostp(j))) then
9381 if(j.ne.lnapx) then
9382 do 35 jj=j,lnapx-1
9383 jj1=jj+1
9384 nlostp(jj)=nlostp(jj1)
9385 xv(1,jj)=xv(1,jj1)
9386 xv(2,jj)=xv(2,jj1)
9387 yv(1,jj)=yv(1,jj1)
9388 yv(2,jj)=yv(2,jj1)
9389 dpsv(jj)=dpsv(jj1)
9390 sigmv(jj)=sigmv(jj1)
9391 ejfv(jj)=ejfv(jj1)
9392 ejv(jj)=ejv(jj1)
9393 rvv(jj)=rvv(jj1)
9394 oidpsv(jj)=oidpsv(jj1)
9395 dpsv1(jj)=dpsv1(jj1)
9396 clo6v(1,jj)=clo6v(1,jj1)
9397 clo6v(2,jj)=clo6v(2,jj1)
9398 clo6v(3,jj)=clo6v(3,jj1)
9399 clop6v(1,jj)=clop6v(1,jj1)
9400 clop6v(2,jj)=clop6v(2,jj1)
9401 clop6v(3,jj)=clop6v(3,jj1)
9402 !--beam-beam element
9403 di0xs(jj)=di0xs(jj1)
9404 dip0xs(jj)=dip0xs(jj1)
9405 di0zs(jj)=di0zs(jj1)
9406 dip0zs(jj)=dip0zs(jj1)
9407 do 210 ib2=1,6
9408 do 210 ib3=1,6
9409 tasau(jj,ib2,ib3)=tasau(jj1,ib2,ib3)
9410 210 continue
9411 35 continue
9412 endif
9413 lnapx=lnapx-1
9414 endif
9415 30 continue
9416 if(lnapx.eq.0) then
9417 write(*,*)
9418 write(*,*)
9419 write(*,*) '***********************'
9420 write(*,*) '** ALL PARTICLE LOST **'
9421 write(*,*) '** PROGRAM STOPS **'
9422 write(*,*) '***********************'
9423 write(*,*)
9424 write(*,*)
9425 nthinerr=3001
9426 return
9427 endif
9428 if(ithick.eq.1.and.ilostch.eq.1) &
9429 &call synuthck
9430 napx=lnapx
9431 return
9432 10000 format(t10,'TRACKING ENDED ABNORMALLY'/t10, 'PARTICLE ',i3, &
9433 &' RANDOM SEED ',i8,/ t10,' MOMENTUM DEVIATION ',g12.5, &
9434 &' LOST IN REVOLUTION ',i8,/ t10,'HORIZ: AMPLITUDE = ',f15.3, &
9435 &' APERTURE = ',f15.3/ t10,'VERT: AMPLITUDE = ',f15.3, &
9436 &' APERTURE = ',f15.3/)
9437 end
9438 subroutine lostpar2(i,ix,nthinerr)
9439 !-----------------------------------------------------------------------
9440 !
9441 ! F. SCHMIDT
9442 !-----------------------------------------------------------------------
9443 ! 3 February 1999
9444 !-----------------------------------------------------------------------
9445 implicit none
9446 ! logical isnan
9447 logical myisnan
9448 integer i,ib2,ib3,ilostch,ix,j,jj,jj1,lnapx,nthinerr
9449 integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1, &
9450 &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran, &
9451 &nrco,ntr,nzfz
9452 parameter(npart = 64,nmac = 1)
9453 parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000, &
9454 &nzfz = 300000,mmul = 11)
9455 parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5, &
9456 &nema = 15)
9457 parameter(mcor = 10,mcop = mcor+6, mbea = 15)
9458 parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
9459 parameter(nmon1 = 600,ncor1 = 600)
9460 parameter(ntr = 20,nbb = 160)
9461 double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3, &
9462 &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21, &
9463 &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
9464 &one,pieni,pmae,pmap,three,two,zero
9465 parameter(pieni = 1d-38)
9466 parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
9467 parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
9468 parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
9469 parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
9470 parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 = &
9471 &1.0d16)
9472 parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
9473 parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
9474 parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
9475 parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
9476 parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
9477 parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
9478 parameter(pmap = 938.271998d0,pmae = .510998902d0)
9479 parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
9480 integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo, &
9481 &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor, &
9482 &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb, &
9483 &imc,imtr,iorg,iout, &
9484 &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires, &
9485 &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw, &
9486 &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox, &
9487 &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo, &
9488 &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx, &
9489 &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr, &
9490 &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew, &
9491 &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr, &
9492 &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
9493 double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu, &
9494 &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
9495 &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft, &
9496 &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
9497 &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign, &
9498 &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum, &
9499 &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
9500 &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph, &
9501 &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
9502 &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel, &
9503 &acdipph
9504 real hmal
9505 character*16 bez,bezb,bezr,erbez,bezl
9506 character*80 toptit,sixtit,commen
9507 common/erro/ierro,erbez
9508 common/kons/pi,pi2,pisqrt,rad
9509 common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
9510 common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
9511 common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
9512 common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
9513 common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
9514 common/syos2/rvf(mpa)
9515 common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
9516 &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
9517 common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3), &
9518 &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen, &
9519 &iicav,itionc(nele),ition,idp,ncy,ixcav
9520 common/corcom/dpscor,sigcor,icode,idam,its6d
9521 common/multi/bk0(nele,mmul),ak0(nele,mmul), &
9522 &bka(nele,mmul),aka(nele,mmul)
9523 common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
9524 common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
9525 common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz), &
9526 &tilts(nblz),mout2,icext(nblz),icextal(nblz)
9527 common/beo /aper(2),di0(2),dip0(2),ta(6,6)
9528 common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
9529 &iout
9530 common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
9531 common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint, &
9532 &ntco,eui,euii,nlin,bezl(nele)
9533 common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2), &
9534 &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr, &
9535 &ncororb(nele)
9536 common/apert/apx(nele),apz(nele),ape(3,nele)
9537 common/clos/sigma0(2),iclo,ncorru,ncorrep
9538 common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20), &
9539 &ratioe(nele),iratioe(nele),icoe
9540 common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
9541 common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
9542 common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
9543 common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
9544 common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2, &
9545 &nstart,nstop,iskip,iconv,imad
9546 common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
9547 common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
9548 common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
9549 common/ripp2/nrturn
9550 common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
9551 common/pawc/hmal(nplo)
9552 common/tit/sixtit,commen,ithick
9553 common/co6d/clo6(3),clop6(3)
9554 common/dkic/dki(nele,3)
9555 common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb), &
9556 &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart), &
9557 &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar, &
9558 &nbeam,ibbc,ibeco,ibtyp,lhc
9559 common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
9560 common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
9561 common/wireco/ wirel(nele)
9562 common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele), &
9563 &nturn3(nele), nturn4(nele)
9564 integer nnumxv
9565 common/postr2/nnumxv(npart)
9566 integer idz,itra
9567 double precision al,as,chi0,chid,dp1,dps,exz,sigm
9568 common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa), &
9569 &dps(mpa),idz(2)
9570 common/anf/chi0,chid,exz(2,6),dp1,itra
9571 integer ichrom,is
9572 double precision alf0,amp,bet0,clo,clop,cro,x,y
9573 common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
9574 common/chrom/cro(2),is(2),ichrom
9575 integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
9576 &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
9577 double precision dpmax,preda,weig1,weig2
9578 character*16 coel
9579 common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
9580 common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
9581 common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
9582 &coel(10)
9583 double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
9584 &zsi
9585 real tlim,time0,time1
9586 common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz), &
9587 &aai(nblz,mmul),bbi(nblz,mmul)
9588 common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
9589 common/damp/damp,ampt
9590 common/ttime/tlim,time0,time1
9591 double precision tasm
9592 common/tasm/tasm(6,6)
9593 integer iv,ixv,nlostp,nms,numxv
9594 double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
9595 &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
9596 &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl, &
9597 &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
9598 &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv, &
9599 &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas, &
9600 &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
9601 &zsiv,zsv
9602 logical pstop
9603 common/main1/ &
9604 &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz), &
9605 &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz), &
9606 &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2), &
9607 &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart), &
9608 &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart), &
9609 &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart), &
9610 &xlv(npart),zlv(npart),pstop(npart),rvv(npart), &
9611 &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
9612 common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart), &
9613 &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart), &
9614 &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart), &
9615 &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart), &
9616 &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart), &
9617 &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
9618 &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
9619 &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart), &
9620 &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
9621 common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo), &
9622 &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart), &
9623 &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6), &
9624 &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
9625 integer numx
9626 double precision e0f
9627 common/main4/ e0f,numx
9628 integer ktrack,nwri
9629 double precision dpsv1,strack,strackc,stracks
9630 common/track/ ktrack(nblz),strack(nblz),strackc(nblz), &
9631 &stracks(nblz),dpsv1(npart),nwri
9632 save
9633 !-----------------------------------------------------------------------
9634 ilostch=0
9635 do 10 j=1,napx
9636 if(abs(xv(1,j)).gt.aper(1).or.abs(xv(2,j)).gt.aper(2).or. &
9637 ! &isnan(xv(1,j),xv(1,j)).or.isnan(xv(2,j),xv(2,j))) then
9638 &myisnan(xv(1,j),xv(1,j)).or.myisnan(xv(2,j),xv(2,j))) then
9639 ilostch=1
9640 pstop(nlostp(j))=.true.
9641 endif
9642 10 continue
9643 do 20 j=1,napx
9644 if(pstop(nlostp(j))) then
9645 aperv(nlostp(j),1)=aper(1)
9646 aperv(nlostp(j),2)=aper(2)
9647 iv(nlostp(j))=i
9648 ixv(nlostp(j))=ix
9649 xvl(1,nlostp(j))=xv(1,j)
9650 xvl(2,nlostp(j))=xv(2,j)
9651 yvl(1,nlostp(j))=yv(1,j)
9652 yvl(2,nlostp(j))=yv(2,j)
9653 dpsvl(nlostp(j))=dpsv(j)
9654 ejvl(nlostp(j))=ejv(j)
9655 sigmvl(nlostp(j))=sigmv(j)
9656 numxv(nlostp(j))=numx
9657 nnumxv(nlostp(j))=numx
9658 if(mod(nlostp(j),2).eq.one) then
9659 write(*,10000) nlostp(j),nms(nlostp(j))*izu0, &
9660 &dp0v(nlostp(j)),numxv(nlostp(j)),iv(nlostp(j)), &
9661 &abs(xvl(1,nlostp(j))),aperv(nlostp(j),1), &
9662 &abs(xvl(2,nlostp(j))),aperv(nlostp(j),2), &
9663 &ixv(nlostp(j)),kz(ixv(nlostp(j))),bez(ixv(nlostp(j)))
9664 else
9665 write(*,10000) nlostp(j),nms(nlostp(j)-1)*izu0, &
9666 &dp0v(nlostp(j)-1),numxv(nlostp(j)),iv(nlostp(j)), &
9667 &abs(xvl(1,nlostp(j))),aperv(nlostp(j),1), &
9668 &abs(xvl(2,nlostp(j))),aperv(nlostp(j),2), &
9669 &ixv(nlostp(j)),kz(ixv(nlostp(j))),bez(ixv(nlostp(j)))
9670 endif
9671 endif
9672 20 continue
9673 lnapx=napx
9674 do 30 j=napx,1,-1
9675 if(pstop(nlostp(j))) then
9676 if(j.ne.lnapx) then
9677 do 35 jj=j,lnapx-1
9678 jj1=jj+1
9679 nlostp(jj)=nlostp(jj1)
9680 xv(1,jj)=xv(1,jj1)
9681 xv(2,jj)=xv(2,jj1)
9682 yv(1,jj)=yv(1,jj1)
9683 yv(2,jj)=yv(2,jj1)
9684 dpsv(jj)=dpsv(jj1)
9685 sigmv(jj)=sigmv(jj1)
9686 ejfv(jj)=ejfv(jj1)
9687 ejv(jj)=ejv(jj1)
9688 rvv(jj)=rvv(jj1)
9689 oidpsv(jj)=oidpsv(jj1)
9690 dpsv1(jj)=dpsv1(jj1)
9691 clo6v(1,jj)=clo6v(1,jj1)
9692 clo6v(2,jj)=clo6v(2,jj1)
9693 clo6v(3,jj)=clo6v(3,jj1)
9694 clop6v(1,jj)=clop6v(1,jj1)
9695 clop6v(2,jj)=clop6v(2,jj1)
9696 clop6v(3,jj)=clop6v(3,jj1)
9697 !--beam-beam element
9698 di0xs(jj)=di0xs(jj1)
9699 dip0xs(jj)=dip0xs(jj1)
9700 di0zs(jj)=di0zs(jj1)
9701 dip0zs(jj)=dip0zs(jj1)
9702 do 210 ib2=1,6
9703 do 210 ib3=1,6
9704 tasau(jj,ib2,ib3)=tasau(jj1,ib2,ib3)
9705 210 continue
9706 35 continue
9707 endif
9708 lnapx=lnapx-1
9709 endif
9710 30 continue
9711 if(lnapx.eq.0) then
9712 write(*,*)
9713 write(*,*)
9714 write(*,*) '***********************'
9715 write(*,*) '** ALL PARTICLE LOST **'
9716 write(*,*) '** PROGRAM STOPS **'
9717 write(*,*) '***********************'
9718 write(*,*)
9719 write(*,*)
9720 nthinerr=3001
9721 return
9722 endif
9723 if(ithick.eq.1.and.ilostch.eq.1) &
9724 &call synuthck
9725 napx=lnapx
9726 return
9727 10000 format(t10,'TRACKING ENDED ABNORMALLY'/t10, 'PARTICLE ',i3, &
9728 &' RANDOM SEED ',i8, ' MOMENTUM DEVIATION ',g12.5/ t10, &
9729 &' LOST IN REVOLUTION ',i8,' AT ELEMENT ',i4/ t10, &
9730 &'HORIZ: AMPLITUDE = ',f15.3,'RE-APERTURE = ',f15.3/ t10, &
9731 &'VERT: AMPLITUDE = ',f15.3,'RE-APERTURE = ',f15.3/ t10, &
9732 &'ELEMENT - LIST NUMBER ',i4,' TYP NUMBER ',i4,' NAME ',a16/)
9733 end
9734 subroutine lostpar3(i,ix,nthinerr)
9735 !-----------------------------------------------------------------------
9736 !
9737 ! F. SCHMIDT
9738 !-----------------------------------------------------------------------
9739 ! 3 February 1999
9740 !-----------------------------------------------------------------------
9741 implicit none
9742 ! logical isnan
9743 logical myisnan
9744 integer i,ib2,ib3,ilostch,ix,j,jj,jj1,lnapx,nthinerr
9745 integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1, &
9746 &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran, &
9747 &nrco,ntr,nzfz
9748 parameter(npart = 64,nmac = 1)
9749 parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000, &
9750 &nzfz = 300000,mmul = 11)
9751 parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5, &
9752 &nema = 15)
9753 parameter(mcor = 10,mcop = mcor+6, mbea = 15)
9754 parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
9755 parameter(nmon1 = 600,ncor1 = 600)
9756 parameter(ntr = 20,nbb = 160)
9757 double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3, &
9758 &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21, &
9759 &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
9760 &one,pieni,pmae,pmap,three,two,zero
9761 parameter(pieni = 1d-38)
9762 parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
9763 parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
9764 parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
9765 parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
9766 parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 = &
9767 &1.0d16)
9768 parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
9769 parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
9770 parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
9771 parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
9772 parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
9773 parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
9774 parameter(pmap = 938.271998d0,pmae = .510998902d0)
9775 parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
9776 integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo, &
9777 &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor, &
9778 &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb, &
9779 &imc,imtr,iorg,iout, &
9780 &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires, &
9781 &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw, &
9782 &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox, &
9783 &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo, &
9784 &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx, &
9785 &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr, &
9786 &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew, &
9787 &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr, &
9788 &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
9789 double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu, &
9790 &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
9791 &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft, &
9792 &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
9793 &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign, &
9794 &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum, &
9795 &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
9796 &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph, &
9797 &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
9798 &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel, &
9799 &acdipph
9800 real hmal
9801 character*16 bez,bezb,bezr,erbez,bezl
9802 character*80 toptit,sixtit,commen
9803 common/erro/ierro,erbez
9804 common/kons/pi,pi2,pisqrt,rad
9805 common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
9806 common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
9807 common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
9808 common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
9809 common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
9810 common/syos2/rvf(mpa)
9811 common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
9812 &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
9813 common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3), &
9814 &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen, &
9815 &iicav,itionc(nele),ition,idp,ncy,ixcav
9816 common/corcom/dpscor,sigcor,icode,idam,its6d
9817 common/multi/bk0(nele,mmul),ak0(nele,mmul), &
9818 &bka(nele,mmul),aka(nele,mmul)
9819 common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
9820 common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
9821 common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz), &
9822 &tilts(nblz),mout2,icext(nblz),icextal(nblz)
9823 common/beo /aper(2),di0(2),dip0(2),ta(6,6)
9824 common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
9825 &iout
9826 common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
9827 common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint, &
9828 &ntco,eui,euii,nlin,bezl(nele)
9829 common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2), &
9830 &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr, &
9831 &ncororb(nele)
9832 common/apert/apx(nele),apz(nele),ape(3,nele)
9833 common/clos/sigma0(2),iclo,ncorru,ncorrep
9834 common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20), &
9835 &ratioe(nele),iratioe(nele),icoe
9836 common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
9837 common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
9838 common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
9839 common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
9840 common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2, &
9841 &nstart,nstop,iskip,iconv,imad
9842 common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
9843 common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
9844 common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
9845 common/ripp2/nrturn
9846 common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
9847 common/pawc/hmal(nplo)
9848 common/tit/sixtit,commen,ithick
9849 common/co6d/clo6(3),clop6(3)
9850 common/dkic/dki(nele,3)
9851 common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb), &
9852 &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart), &
9853 &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar, &
9854 &nbeam,ibbc,ibeco,ibtyp,lhc
9855 common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
9856 common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
9857 common/wireco/ wirel(nele)
9858 common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele), &
9859 &nturn3(nele), nturn4(nele)
9860 integer nnumxv
9861 common/postr2/nnumxv(npart)
9862 integer idz,itra
9863 double precision al,as,chi0,chid,dp1,dps,exz,sigm
9864 common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa), &
9865 &dps(mpa),idz(2)
9866 common/anf/chi0,chid,exz(2,6),dp1,itra
9867 integer ichrom,is
9868 double precision alf0,amp,bet0,clo,clop,cro,x,y
9869 common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
9870 common/chrom/cro(2),is(2),ichrom
9871 integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
9872 &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
9873 double precision dpmax,preda,weig1,weig2
9874 character*16 coel
9875 common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
9876 common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
9877 common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
9878 &coel(10)
9879 double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
9880 &zsi
9881 real tlim,time0,time1
9882 common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz), &
9883 &aai(nblz,mmul),bbi(nblz,mmul)
9884 common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
9885 common/damp/damp,ampt
9886 common/ttime/tlim,time0,time1
9887 double precision tasm
9888 common/tasm/tasm(6,6)
9889 integer iv,ixv,nlostp,nms,numxv
9890 double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
9891 &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
9892 &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl, &
9893 &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
9894 &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv, &
9895 &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas, &
9896 &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
9897 &zsiv,zsv
9898 logical pstop
9899 common/main1/ &
9900 &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz), &
9901 &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz), &
9902 &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2), &
9903 &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart), &
9904 &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart), &
9905 &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart), &
9906 &xlv(npart),zlv(npart),pstop(npart),rvv(npart), &
9907 &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
9908 common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart), &
9909 &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart), &
9910 &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart), &
9911 &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart), &
9912 &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart), &
9913 &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
9914 &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
9915 &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart), &
9916 &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
9917 common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo), &
9918 &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart), &
9919 &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6), &
9920 &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
9921 integer numx
9922 double precision e0f
9923 common/main4/ e0f,numx
9924 integer ktrack,nwri
9925 double precision dpsv1,strack,strackc,stracks
9926 common/track/ ktrack(nblz),strack(nblz),strackc(nblz), &
9927 &stracks(nblz),dpsv1(npart),nwri
9928 save
9929 !-----------------------------------------------------------------------
9930 ilostch=0
9931 do 10 j=1,napx
9932 if(abs(xv(1,j)).gt.apx(ix).or.abs(xv(2,j)).gt.apz(ix).or. &
9933 ! &isnan(xv(1,j),xv(1,j)).or.isnan(xv(2,j),xv(2,j))) then
9934 &myisnan(xv(1,j),xv(1,j)).or.myisnan(xv(2,j),xv(2,j))) then
9935 ilostch=1
9936 pstop(nlostp(j))=.true.
9937 endif
9938 10 continue
9939 do 20 j=1,napx
9940 if(pstop(nlostp(j))) then
9941 aperv(nlostp(j),1)=apx(ix)
9942 aperv(nlostp(j),2)=apz(ix)
9943 iv(nlostp(j))=i
9944 ixv(nlostp(j))=ix
9945 xvl(1,nlostp(j))=xv(1,j)
9946 xvl(2,nlostp(j))=xv(2,j)
9947 yvl(1,nlostp(j))=yv(1,j)
9948 yvl(2,nlostp(j))=yv(2,j)
9949 dpsvl(nlostp(j))=dpsv(j)
9950 ejvl(nlostp(j))=ejv(j)
9951 sigmvl(nlostp(j))=sigmv(j)
9952 numxv(nlostp(j))=numx
9953 nnumxv(nlostp(j))=numx
9954 if(mod(nlostp(j),2).eq.one) then
9955 write(*,10000) nlostp(j),nms(nlostp(j))*izu0, &
9956 &dp0v(nlostp(j)),numxv(nlostp(j)),iv(nlostp(j)), &
9957 &abs(xvl(1,nlostp(j))),aperv(nlostp(j),1), &
9958 &abs(xvl(2,nlostp(j))),aperv(nlostp(j),2), &
9959 &ixv(nlostp(j)),kz(ixv(nlostp(j))),bez(ixv(nlostp(j)))
9960 else
9961 write(*,10000) nlostp(j),nms(nlostp(j)-1)*izu0, &
9962 &dp0v(nlostp(j)-1),numxv(nlostp(j)),iv(nlostp(j)), &
9963 &abs(xvl(1,nlostp(j))),aperv(nlostp(j),1), &
9964 &abs(xvl(2,nlostp(j))),aperv(nlostp(j),2), &
9965 &ixv(nlostp(j)),kz(ixv(nlostp(j))),bez(ixv(nlostp(j)))
9966 endif
9967 endif
9968 20 continue
9969 lnapx=napx
9970 do 30 j=napx,1,-1
9971 if(pstop(nlostp(j))) then
9972 if(j.ne.lnapx) then
9973 do 35 jj=j,lnapx-1
9974 jj1=jj+1
9975 nlostp(jj)=nlostp(jj1)
9976 xv(1,jj)=xv(1,jj1)
9977 xv(2,jj)=xv(2,jj1)
9978 yv(1,jj)=yv(1,jj1)
9979 yv(2,jj)=yv(2,jj1)
9980 dpsv(jj)=dpsv(jj1)
9981 sigmv(jj)=sigmv(jj1)
9982 ejfv(jj)=ejfv(jj1)
9983 ejv(jj)=ejv(jj1)
9984 rvv(jj)=rvv(jj1)
9985 oidpsv(jj)=oidpsv(jj1)
9986 dpsv1(jj)=dpsv1(jj1)
9987 clo6v(1,jj)=clo6v(1,jj1)
9988 clo6v(2,jj)=clo6v(2,jj1)
9989 clo6v(3,jj)=clo6v(3,jj1)
9990 clop6v(1,jj)=clop6v(1,jj1)
9991 clop6v(2,jj)=clop6v(2,jj1)
9992 clop6v(3,jj)=clop6v(3,jj1)
9993 !--beam-beam element
9994 di0xs(jj)=di0xs(jj1)
9995 dip0xs(jj)=dip0xs(jj1)
9996 di0zs(jj)=di0zs(jj1)
9997 dip0zs(jj)=dip0zs(jj1)
9998 do 210 ib2=1,6
9999 do 210 ib3=1,6
10000 tasau(jj,ib2,ib3)=tasau(jj1,ib2,ib3)
10001 210 continue
10002 35 continue
10003 endif
10004 lnapx=lnapx-1
10005 endif
10006 30 continue
10007 if(lnapx.eq.0) then
10008 write(*,*)
10009 write(*,*)
10010 write(*,*) '***********************'
10011 write(*,*) '** ALL PARTICLE LOST **'
10012 write(*,*) '** PROGRAM STOPS **'
10013 write(*,*) '***********************'
10014 write(*,*)
10015 write(*,*)
10016 nthinerr=3001
10017 return
10018 endif
10019 if(ithick.eq.1.and.ilostch.eq.1) &
10020 &call synuthck
10021 napx=lnapx
10022 return
10023 10000 format(t10,'TRACKING ENDED ABNORMALLY'/t10, 'PARTICLE ',i3, &
10024 &' RANDOM SEED ',i8, ' MOMENTUM DEVIATION ',g12.5/ t10, &
10025 &' LOST IN REVOLUTION ',i8,' AT ELEMENT ',i4/ t10, &
10026 &'HORIZ: AMPLITUDE = ',f15.3,'RE-APERTURE = ',f15.3/ t10, &
10027 &'VERT: AMPLITUDE = ',f15.3,'RE-APERTURE = ',f15.3/ t10, &
10028 &'ELEMENT - LIST NUMBER ',i4,' TYP NUMBER ',i4,' NAME ',a16/)
10029 end
10030 subroutine lostpar4(i,ix,nthinerr)
10031 !-----------------------------------------------------------------------
10032 !
10033 ! F. SCHMIDT
10034 !-----------------------------------------------------------------------
10035 ! 3 February 1999
10036 !-----------------------------------------------------------------------
10037 implicit none
10038 ! logical isnan
10039 logical myisnan
10040 integer i,ib2,ib3,ilostch,ix,j,jj,jj1,lnapx,nthinerr
10041 integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1, &
10042 &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran, &
10043 &nrco,ntr,nzfz
10044 parameter(npart = 64,nmac = 1)
10045 parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000, &
10046 &nzfz = 300000,mmul = 11)
10047 parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5, &
10048 &nema = 15)
10049 parameter(mcor = 10,mcop = mcor+6, mbea = 15)
10050 parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
10051 parameter(nmon1 = 600,ncor1 = 600)
10052 parameter(ntr = 20,nbb = 160)
10053 double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3, &
10054 &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21, &
10055 &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
10056 &one,pieni,pmae,pmap,three,two,zero
10057 parameter(pieni = 1d-38)
10058 parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
10059 parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
10060 parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
10061 parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
10062 parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 = &
10063 &1.0d16)
10064 parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
10065 parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
10066 parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
10067 parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
10068 parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
10069 parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
10070 parameter(pmap = 938.271998d0,pmae = .510998902d0)
10071 parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
10072 integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo, &
10073 &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor, &
10074 &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb, &
10075 &imc,imtr,iorg,iout, &
10076 &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires, &
10077 &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw, &
10078 &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox, &
10079 &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo, &
10080 &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx, &
10081 &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr, &
10082 &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew, &
10083 &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr, &
10084 &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
10085 double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu, &
10086 &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
10087 &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft, &
10088 &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
10089 &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign, &
10090 &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum, &
10091 &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
10092 &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph, &
10093 &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
10094 &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel, &
10095 &acdipph
10096 real hmal
10097 character*16 bez,bezb,bezr,erbez,bezl
10098 character*80 toptit,sixtit,commen
10099 common/erro/ierro,erbez
10100 common/kons/pi,pi2,pisqrt,rad
10101 common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
10102 common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
10103 common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
10104 common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
10105 common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
10106 common/syos2/rvf(mpa)
10107 common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
10108 &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
10109 common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3), &
10110 &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen, &
10111 &iicav,itionc(nele),ition,idp,ncy,ixcav
10112 common/corcom/dpscor,sigcor,icode,idam,its6d
10113 common/multi/bk0(nele,mmul),ak0(nele,mmul), &
10114 &bka(nele,mmul),aka(nele,mmul)
10115 common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
10116 common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
10117 common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz), &
10118 &tilts(nblz),mout2,icext(nblz),icextal(nblz)
10119 common/beo /aper(2),di0(2),dip0(2),ta(6,6)
10120 common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
10121 &iout
10122 common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
10123 common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint, &
10124 &ntco,eui,euii,nlin,bezl(nele)
10125 common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2), &
10126 &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr, &
10127 &ncororb(nele)
10128 common/apert/apx(nele),apz(nele),ape(3,nele)
10129 common/clos/sigma0(2),iclo,ncorru,ncorrep
10130 common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20), &
10131 &ratioe(nele),iratioe(nele),icoe
10132 common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
10133 common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
10134 common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
10135 common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
10136 common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2, &
10137 &nstart,nstop,iskip,iconv,imad
10138 common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
10139 common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
10140 common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
10141 common/ripp2/nrturn
10142 common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
10143 common/pawc/hmal(nplo)
10144 common/tit/sixtit,commen,ithick
10145 common/co6d/clo6(3),clop6(3)
10146 common/dkic/dki(nele,3)
10147 common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb), &
10148 &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart), &
10149 &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar, &
10150 &nbeam,ibbc,ibeco,ibtyp,lhc
10151 common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
10152 common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
10153 common/wireco/ wirel(nele)
10154 common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele), &
10155 &nturn3(nele), nturn4(nele)
10156 integer nnumxv
10157 common/postr2/nnumxv(npart)
10158 integer idz,itra
10159 double precision al,as,chi0,chid,dp1,dps,exz,sigm
10160 common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa), &
10161 &dps(mpa),idz(2)
10162 common/anf/chi0,chid,exz(2,6),dp1,itra
10163 integer ichrom,is
10164 double precision alf0,amp,bet0,clo,clop,cro,x,y
10165 common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
10166 common/chrom/cro(2),is(2),ichrom
10167 integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
10168 &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
10169 double precision dpmax,preda,weig1,weig2
10170 character*16 coel
10171 common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
10172 common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
10173 common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
10174 &coel(10)
10175 double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
10176 &zsi
10177 real tlim,time0,time1
10178 common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz), &
10179 &aai(nblz,mmul),bbi(nblz,mmul)
10180 common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
10181 common/damp/damp,ampt
10182 common/ttime/tlim,time0,time1
10183 double precision tasm
10184 common/tasm/tasm(6,6)
10185 integer iv,ixv,nlostp,nms,numxv
10186 double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
10187 &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
10188 &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl, &
10189 &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
10190 &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv, &
10191 &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas, &
10192 &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
10193 &zsiv,zsv
10194 logical pstop
10195 common/main1/ &
10196 &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz), &
10197 &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz), &
10198 &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2), &
10199 &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart), &
10200 &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart), &
10201 &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart), &
10202 &xlv(npart),zlv(npart),pstop(npart),rvv(npart), &
10203 &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
10204 common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart), &
10205 &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart), &
10206 &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart), &
10207 &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart), &
10208 &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart), &
10209 &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
10210 &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
10211 &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart), &
10212 &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
10213 common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo), &
10214 &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart), &
10215 &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6), &
10216 &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
10217 integer numx
10218 double precision e0f
10219 common/main4/ e0f,numx
10220 integer ktrack,nwri
10221 double precision dpsv1,strack,strackc,stracks
10222 common/track/ ktrack(nblz),strack(nblz),strackc(nblz), &
10223 &stracks(nblz),dpsv1(npart),nwri
10224 save
10225 !-----------------------------------------------------------------------
10226 ilostch=0
10227 do 10 j=1,napx
10228 if(xv(1,j)*xv(1,j)*ape(1,ix)+xv(2,j)*xv(2,j)*ape(2,ix).gt. &
10229 &ape(3,ix).or. &
10230 ! &isnan(xv(1,j),xv(1,j)).or.isnan(xv(2,j),xv(2,j))) then
10231 &myisnan(xv(1,j),xv(1,j)).or.myisnan(xv(2,j),xv(2,j))) then
10232 ilostch=1
10233 pstop(nlostp(j))=.true.
10234 endif
10235 10 continue
10236 do 20 j=1,napx
10237 if(pstop(nlostp(j))) then
10238 aperv(nlostp(j),1)=apx(ix)
10239 aperv(nlostp(j),2)=apz(ix)
10240 iv(nlostp(j))=i
10241 ixv(nlostp(j))=ix
10242 xvl(1,nlostp(j))=xv(1,j)
10243 xvl(2,nlostp(j))=xv(2,j)
10244 yvl(1,nlostp(j))=yv(1,j)
10245 yvl(2,nlostp(j))=yv(2,j)
10246 dpsvl(nlostp(j))=dpsv(j)
10247 ejvl(nlostp(j))=ejv(j)
10248 sigmvl(nlostp(j))=sigmv(j)
10249 numxv(nlostp(j))=numx
10250 nnumxv(nlostp(j))=numx
10251 if(mod(nlostp(j),2).eq.one) then
10252 write(*,10000) nlostp(j),nms(nlostp(j))*izu0, &
10253 &dp0v(nlostp(j)),numxv(nlostp(j)),iv(nlostp(j)), &
10254 &abs(xvl(1,nlostp(j))),aperv(nlostp(j),1), &
10255 &abs(xvl(2,nlostp(j))),aperv(nlostp(j),2), &
10256 &ixv(nlostp(j)),kz(ixv(nlostp(j))),bez(ixv(nlostp(j)))
10257 else
10258 write(*,10000) nlostp(j),nms(nlostp(j)-1)*izu0, &
10259 &dp0v(nlostp(j)-1),numxv(nlostp(j)),iv(nlostp(j)), &
10260 &abs(xvl(1,nlostp(j))),aperv(nlostp(j),1), &
10261 &abs(xvl(2,nlostp(j))),aperv(nlostp(j),2), &
10262 &ixv(nlostp(j)),kz(ixv(nlostp(j))),bez(ixv(nlostp(j)))
10263 endif
10264 endif
10265 20 continue
10266 lnapx=napx
10267 do 30 j=napx,1,-1
10268 if(pstop(nlostp(j))) then
10269 if(j.ne.lnapx) then
10270 do 35 jj=j,lnapx-1
10271 jj1=jj+1
10272 nlostp(jj)=nlostp(jj1)
10273 xv(1,jj)=xv(1,jj1)
10274 xv(2,jj)=xv(2,jj1)
10275 yv(1,jj)=yv(1,jj1)
10276 yv(2,jj)=yv(2,jj1)
10277 dpsv(jj)=dpsv(jj1)
10278 sigmv(jj)=sigmv(jj1)
10279 ejfv(jj)=ejfv(jj1)
10280 ejv(jj)=ejv(jj1)
10281 rvv(jj)=rvv(jj1)
10282 oidpsv(jj)=oidpsv(jj1)
10283 dpsv1(jj)=dpsv1(jj1)
10284 clo6v(1,jj)=clo6v(1,jj1)
10285 clo6v(2,jj)=clo6v(2,jj1)
10286 clo6v(3,jj)=clo6v(3,jj1)
10287 clop6v(1,jj)=clop6v(1,jj1)
10288 clop6v(2,jj)=clop6v(2,jj1)
10289 clop6v(3,jj)=clop6v(3,jj1)
10290 !--beam-beam element
10291 di0xs(jj)=di0xs(jj1)
10292 dip0xs(jj)=dip0xs(jj1)
10293 di0zs(jj)=di0zs(jj1)
10294 dip0zs(jj)=dip0zs(jj1)
10295 do 210 ib2=1,6
10296 do 210 ib3=1,6
10297 tasau(jj,ib2,ib3)=tasau(jj1,ib2,ib3)
10298 210 continue
10299 35 continue
10300 endif
10301 lnapx=lnapx-1
10302 endif
10303 30 continue
10304 if(lnapx.eq.0) then
10305 write(*,*)
10306 write(*,*)
10307 write(*,*) '***********************'
10308 write(*,*) '** ALL PARTICLE LOST **'
10309 write(*,*) '** PROGRAM STOPS **'
10310 write(*,*) '***********************'
10311 write(*,*)
10312 write(*,*)
10313 nthinerr=3001
10314 return
10315 endif
10316 if(ithick.eq.1.and.ilostch.eq.1) &
10317 &call synuthck
10318 napx=lnapx
10319 return
10320 10000 format(t10,'TRACKING ENDED ABNORMALLY'/t10, 'PARTICLE ',i3, &
10321 &' RANDOM SEED ',i8, ' MOMENTUM DEVIATION ',g12.5/ t10, &
10322 &' LOST IN REVOLUTION ',i8,' AT ELEMENT ',i4/ t10, &
10323 &'HORIZ: AMPLITUDE = ',f15.3,'EL-APERTURE = ',f15.3/ t10, &
10324 &'VERT: AMPLITUDE = ',f15.3,'EL-APERTURE = ',f15.3/ t10, &
10325 &'ELEMENT - LIST NUMBER ',i4,' TYP NUMBER ',i4,' NAME ',a16/)
10326 end
10327 subroutine dist1
10328 !-----------------------------------------------------------------------
10329 !
10330 ! F. SCHMIDT
10331 !-----------------------------------------------------------------------
10332 ! 3 February 1999
10333 !-----------------------------------------------------------------------
10334 implicit none
10335 integer ia,ib2,ib3,ie
10336 double precision dam1
10337 integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1, &
10338 &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran, &
10339 &nrco,ntr,nzfz
10340 parameter(npart = 64,nmac = 1)
10341 parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000, &
10342 &nzfz = 300000,mmul = 11)
10343 parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5, &
10344 &nema = 15)
10345 parameter(mcor = 10,mcop = mcor+6, mbea = 15)
10346 parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
10347 parameter(nmon1 = 600,ncor1 = 600)
10348 parameter(ntr = 20,nbb = 160)
10349 double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3, &
10350 &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21, &
10351 &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
10352 &one,pieni,pmae,pmap,three,two,zero
10353 parameter(pieni = 1d-38)
10354 parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
10355 parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
10356 parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
10357 parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
10358 parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 = &
10359 &1.0d16)
10360 parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
10361 parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
10362 parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
10363 parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
10364 parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
10365 parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
10366 parameter(pmap = 938.271998d0,pmae = .510998902d0)
10367 parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
10368 integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo, &
10369 &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor, &
10370 &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb, &
10371 &imc,imtr,iorg,iout, &
10372 &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires, &
10373 &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw, &
10374 &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox, &
10375 &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo, &
10376 &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx, &
10377 &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr, &
10378 &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew, &
10379 &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr, &
10380 &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
10381 double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu, &
10382 &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
10383 &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft, &
10384 &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
10385 &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign, &
10386 &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum, &
10387 &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
10388 &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph, &
10389 &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
10390 &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel, &
10391 &acdipph
10392 real hmal
10393 character*16 bez,bezb,bezr,erbez,bezl
10394 character*80 toptit,sixtit,commen
10395 common/erro/ierro,erbez
10396 common/kons/pi,pi2,pisqrt,rad
10397 common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
10398 common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
10399 common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
10400 common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
10401 common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
10402 common/syos2/rvf(mpa)
10403 common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
10404 &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
10405 common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3), &
10406 &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen, &
10407 &iicav,itionc(nele),ition,idp,ncy,ixcav
10408 common/corcom/dpscor,sigcor,icode,idam,its6d
10409 common/multi/bk0(nele,mmul),ak0(nele,mmul), &
10410 &bka(nele,mmul),aka(nele,mmul)
10411 common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
10412 common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
10413 common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz), &
10414 &tilts(nblz),mout2,icext(nblz),icextal(nblz)
10415 common/beo /aper(2),di0(2),dip0(2),ta(6,6)
10416 common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
10417 &iout
10418 common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
10419 common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint, &
10420 &ntco,eui,euii,nlin,bezl(nele)
10421 common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2), &
10422 &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr, &
10423 &ncororb(nele)
10424 common/apert/apx(nele),apz(nele),ape(3,nele)
10425 common/clos/sigma0(2),iclo,ncorru,ncorrep
10426 common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20), &
10427 &ratioe(nele),iratioe(nele),icoe
10428 common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
10429 common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
10430 common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
10431 common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
10432 common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2, &
10433 &nstart,nstop,iskip,iconv,imad
10434 common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
10435 common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
10436 common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
10437 common/ripp2/nrturn
10438 common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
10439 common/pawc/hmal(nplo)
10440 common/tit/sixtit,commen,ithick
10441 common/co6d/clo6(3),clop6(3)
10442 common/dkic/dki(nele,3)
10443 common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb), &
10444 &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart), &
10445 &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar, &
10446 &nbeam,ibbc,ibeco,ibtyp,lhc
10447 common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
10448 common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
10449 common/wireco/ wirel(nele)
10450 common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele), &
10451 &nturn3(nele), nturn4(nele)
10452 integer idz,itra
10453 double precision al,as,chi0,chid,dp1,dps,exz,sigm
10454 common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa), &
10455 &dps(mpa),idz(2)
10456 common/anf/chi0,chid,exz(2,6),dp1,itra
10457 integer ichrom,is
10458 double precision alf0,amp,bet0,clo,clop,cro,x,y
10459 common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
10460 common/chrom/cro(2),is(2),ichrom
10461 integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
10462 &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
10463 double precision dpmax,preda,weig1,weig2
10464 character*16 coel
10465 common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
10466 common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
10467 common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
10468 &coel(10)
10469 double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
10470 &zsi
10471 real tlim,time0,time1
10472 common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz), &
10473 &aai(nblz,mmul),bbi(nblz,mmul)
10474 common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
10475 common/damp/damp,ampt
10476 common/ttime/tlim,time0,time1
10477 double precision tasm
10478 common/tasm/tasm(6,6)
10479 integer iv,ixv,nlostp,nms,numxv
10480 double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
10481 &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
10482 &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl, &
10483 &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
10484 &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv, &
10485 &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas, &
10486 &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
10487 &zsiv,zsv
10488 logical pstop
10489 common/main1/ &
10490 &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz), &
10491 &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz), &
10492 &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2), &
10493 &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart), &
10494 &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart), &
10495 &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart), &
10496 &xlv(npart),zlv(npart),pstop(npart),rvv(npart), &
10497 &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
10498 common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart), &
10499 &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart), &
10500 &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart), &
10501 &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart), &
10502 &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart), &
10503 &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
10504 &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
10505 &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart), &
10506 &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
10507 common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo), &
10508 &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart), &
10509 &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6), &
10510 &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
10511 integer numx
10512 double precision e0f
10513 common/main4/ e0f,numx
10514 integer ktrack,nwri
10515 double precision dpsv1,strack,strackc,stracks
10516 common/track/ ktrack(nblz),strack(nblz),strackc(nblz), &
10517 &stracks(nblz),dpsv1(npart),nwri
10518 save
10519 !-----------------------------------------------------------------------
10520 do 20 ia=1,napx,2
10521 if(.not.pstop(nlostp(ia)).and..not.pstop(nlostp(ia)+1).and. &
10522 &(mod(nlostp(ia),2).ne.0)) then
10523 ie=ia+1
10524 dam(ia)=zero
10525 dam(ie)=zero
10526 xau(1,1)= xv(1,ia)
10527 xau(1,2)= yv(1,ia)
10528 xau(1,3)= xv(2,ia)
10529 xau(1,4)= yv(2,ia)
10530 xau(1,5)=sigmv(ia)
10531 xau(1,6)= dpsv(ia)
10532 xau(2,1)= xv(1,ie)
10533 xau(2,2)= yv(1,ie)
10534 xau(2,3)= xv(2,ie)
10535 xau(2,4)= yv(2,ie)
10536 xau(2,5)=sigmv(ie)
10537 xau(2,6)= dpsv(ie)
10538 cloau(1)= clo6v(1,ia)
10539 cloau(2)=clop6v(1,ia)
10540 cloau(3)= clo6v(2,ia)
10541 cloau(4)=clop6v(2,ia)
10542 cloau(5)= clo6v(3,ia)
10543 cloau(6)=clop6v(3,ia)
10544 di0au(1)= di0xs(ia)
10545 di0au(2)=dip0xs(ia)
10546 di0au(3)= di0zs(ia)
10547 di0au(4)=dip0zs(ia)
10548 do 10 ib2=1,6
10549 do 10 ib3=1,6
10550 tau(ib2,ib3)=tasau(ia,ib2,ib3)
10551 10 continue
10552 call distance(xau,cloau,di0au,tau,dam1)
10553 dam(ia)=dam1
10554 dam(ie)=dam1
10555 endif
10556 20 continue
10557 return
10558 end
10559 subroutine write6(n)
10560 !-----------------------------------------------------------------------
10561 !
10562 ! F. SCHMIDT
10563 !-----------------------------------------------------------------------
10564 ! 3 February 1999
10565 !-----------------------------------------------------------------------
10566 implicit none
10567 integer ia,ia2,id,ie,ig,n
10568 integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1, &
10569 &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran, &
10570 &nrco,ntr,nzfz
10571 parameter(npart = 64,nmac = 1)
10572 parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000, &
10573 &nzfz = 300000,mmul = 11)
10574 parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5, &
10575 &nema = 15)
10576 parameter(mcor = 10,mcop = mcor+6, mbea = 15)
10577 parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
10578 parameter(nmon1 = 600,ncor1 = 600)
10579 parameter(ntr = 20,nbb = 160)
10580 double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3, &
10581 &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21, &
10582 &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
10583 &one,pieni,pmae,pmap,three,two,zero
10584 parameter(pieni = 1d-38)
10585 parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
10586 parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
10587 parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
10588 parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
10589 parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 = &
10590 &1.0d16)
10591 parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
10592 parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
10593 parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
10594 parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
10595 parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
10596 parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
10597 parameter(pmap = 938.271998d0,pmae = .510998902d0)
10598 parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
10599 integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo, &
10600 &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor, &
10601 &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb, &
10602 &imc,imtr,iorg,iout, &
10603 &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires, &
10604 &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw, &
10605 &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox, &
10606 &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo, &
10607 &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx, &
10608 &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr, &
10609 &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew, &
10610 &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr, &
10611 &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
10612 double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu, &
10613 &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
10614 &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft, &
10615 &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
10616 &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign, &
10617 &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum, &
10618 &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
10619 &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph, &
10620 &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
10621 &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel, &
10622 &acdipph
10623 real hmal
10624 character*16 bez,bezb,bezr,erbez,bezl
10625 character*80 toptit,sixtit,commen
10626 common/erro/ierro,erbez
10627 common/kons/pi,pi2,pisqrt,rad
10628 common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
10629 common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
10630 common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
10631 common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
10632 common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
10633 common/syos2/rvf(mpa)
10634 common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
10635 &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
10636 common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3), &
10637 &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen, &
10638 &iicav,itionc(nele),ition,idp,ncy,ixcav
10639 common/corcom/dpscor,sigcor,icode,idam,its6d
10640 common/multi/bk0(nele,mmul),ak0(nele,mmul), &
10641 &bka(nele,mmul),aka(nele,mmul)
10642 common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
10643 common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
10644 common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz), &
10645 &tilts(nblz),mout2,icext(nblz),icextal(nblz)
10646 common/beo /aper(2),di0(2),dip0(2),ta(6,6)
10647 common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
10648 &iout
10649 common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
10650 common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint, &
10651 &ntco,eui,euii,nlin,bezl(nele)
10652 common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2), &
10653 &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr, &
10654 &ncororb(nele)
10655 common/apert/apx(nele),apz(nele),ape(3,nele)
10656 common/clos/sigma0(2),iclo,ncorru,ncorrep
10657 common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20), &
10658 &ratioe(nele),iratioe(nele),icoe
10659 common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
10660 common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
10661 common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
10662 common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
10663 common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2, &
10664 &nstart,nstop,iskip,iconv,imad
10665 common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
10666 common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
10667 common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
10668 common/ripp2/nrturn
10669 common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
10670 common/pawc/hmal(nplo)
10671 common/tit/sixtit,commen,ithick
10672 common/co6d/clo6(3),clop6(3)
10673 common/dkic/dki(nele,3)
10674 common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb), &
10675 &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart), &
10676 &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar, &
10677 &nbeam,ibbc,ibeco,ibtyp,lhc
10678 common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
10679 common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
10680 common/wireco/ wirel(nele)
10681 common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele), &
10682 &nturn3(nele), nturn4(nele)
10683 integer nnumxv
10684 common/postr2/nnumxv(npart)
10685 integer idz,itra
10686 double precision al,as,chi0,chid,dp1,dps,exz,sigm
10687 common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa), &
10688 &dps(mpa),idz(2)
10689 common/anf/chi0,chid,exz(2,6),dp1,itra
10690 integer ichrom,is
10691 double precision alf0,amp,bet0,clo,clop,cro,x,y
10692 common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
10693 common/chrom/cro(2),is(2),ichrom
10694 integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
10695 &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
10696 double precision dpmax,preda,weig1,weig2
10697 character*16 coel
10698 common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
10699 common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
10700 common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
10701 &coel(10)
10702 double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
10703 &zsi
10704 real tlim,time0,time1
10705 common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz), &
10706 &aai(nblz,mmul),bbi(nblz,mmul)
10707 common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
10708 common/damp/damp,ampt
10709 common/ttime/tlim,time0,time1
10710 double precision tasm
10711 common/tasm/tasm(6,6)
10712 integer iv,ixv,nlostp,nms,numxv
10713 double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
10714 &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
10715 &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl, &
10716 &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
10717 &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv, &
10718 &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas, &
10719 &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
10720 &zsiv,zsv
10721 logical pstop
10722 common/main1/ &
10723 &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz), &
10724 &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz), &
10725 &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2), &
10726 &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart), &
10727 &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart), &
10728 &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart), &
10729 &xlv(npart),zlv(npart),pstop(npart),rvv(npart), &
10730 &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
10731 common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart), &
10732 &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart), &
10733 &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart), &
10734 &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart), &
10735 &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart), &
10736 &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
10737 &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
10738 &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart), &
10739 &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
10740 common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo), &
10741 &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart), &
10742 &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6), &
10743 &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
10744 integer numx
10745 double precision e0f
10746 common/main4/ e0f,numx
10747 integer ktrack,nwri
10748 double precision dpsv1,strack,strackc,stracks
10749 common/track/ ktrack(nblz),strack(nblz),strackc(nblz), &
10750 &stracks(nblz),dpsv1(npart),nwri
10751 save
10752 !-----------------------------------------------------------------------
10753 id=0
10754 do 10 ia=1,napxo,2
10755 ig=ia+1
10756 ia2=ig/2
10757 endfile 91-ia2
10758 backspace 91-ia2
10759 !-- PARTICLES STABLE
10760 if(.not.pstop(ia).and..not.pstop(ig)) then
10761 write(*,10000) ia,nms(ia)*izu0,dp0v(ia),n
10762 id=id+1
10763 ie=id+1
10764 write(*,10010) &
10765 &xv(1,id),yv(1,id),xv(2,id),yv(2,id),sigmv(id),dpsv(id), &
10766 &xv(1,ie),yv(1,ie),xv(2,ie),yv(2,ie),sigmv(ie),dpsv(ie), &
10767 &e0,ejv(id),ejv(ie)
10768 write(12,10010,iostat=ierro) &
10769 &xv(1,id),yv(1,id),xv(2,id),yv(2,id),sigmv(id),dpsv(id), &
10770 &xv(1,ie),yv(1,ie),xv(2,ie),yv(2,ie),sigmv(ie),dpsv(ie), &
10771 &e0,ejv(id),ejv(ie)
10772 id=id+1
10773 !-- FIRST PARTICLES LOST
10774 else if(pstop(ia).and..not.pstop(ig)) then
10775 id=id+1
10776 write(12,10010,iostat=ierro) &
10777 &xvl(1,ia),yvl(1,ia),xvl(2,ia),yvl(2,ia),sigmvl(ia),dpsvl(ia), &
10778 &xv(1,id),yv(1,id),xv(2,id),yv(2,id),sigmv(id),dpsv(id), &
10779 &e0,ejvl(ia),ejv(id)
10780 !-- SECOND PARTICLES LOST
10781 else if(.not.pstop(ia).and.pstop(ig)) then
10782 id=id+1
10783 write(12,10010,iostat=ierro) &
10784 &xv(1,id),yv(1,id),xv(2,id),yv(2,id),sigmv(id),dpsv(id), &
10785 &xvl(1,ig),yvl(1,ig),xvl(2,ig),yvl(2,ig),sigmvl(ig),dpsvl(ig), &
10786 &e0,ejv(id),ejvl(ig)
10787 !-- BOTH PARTICLES LOST
10788 else if(pstop(ia).and.pstop(ig)) then
10789 endif
10790 10 continue
10791 if(ierro.ne.0) write(*,*) 'Warning from write6: fort.12 has ', &
10792 &'corrupted output probably due to lost particles'
10793 endfile 12
10794 backspace 12
10795 return
10796 10000 format(1x/5x,'PARTICLE ',i3,' RANDOM SEED ',i8, &
10797 &' MOMENTUM DEVIATION ',g12.5 /5x,'REVOLUTION ',i8/)
10798 10010 format(10x,f47.33)
10799 end
10800 subroutine trauthck(nthinerr)
10801 !-----------------------------------------------------------------------
10802 !
10803 ! TRACK THICK LENS PART
10804 !
10805 !
10806 ! F. SCHMIDT
10807 !-----------------------------------------------------------------------
10808 implicit none
10809 integer i,ix,j,jb,jj,jx,kpz,kzz,napx0,nbeaux,nmz,nthinerr
10810 double precision benkcc,cbxb,cbzb,cikveb,crkveb,crxb,crzb,r0,r000,&
10811 &r0a,r2b,rb,rho2b,rkb,tkb,xbb,xrb,zbb,zrb
10812 integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1, &
10813 &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran, &
10814 &nrco,ntr,nzfz
10815 parameter(npart = 64,nmac = 1)
10816 parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000, &
10817 &nzfz = 300000,mmul = 11)
10818 parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5, &
10819 &nema = 15)
10820 parameter(mcor = 10,mcop = mcor+6, mbea = 15)
10821 parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
10822 parameter(nmon1 = 600,ncor1 = 600)
10823 parameter(ntr = 20,nbb = 160)
10824 double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3, &
10825 &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21, &
10826 &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
10827 &one,pieni,pmae,pmap,three,two,zero
10828 parameter(pieni = 1d-38)
10829 parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
10830 parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
10831 parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
10832 parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
10833 parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 = &
10834 &1.0d16)
10835 parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
10836 parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
10837 parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
10838 parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
10839 parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
10840 parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
10841 parameter(pmap = 938.271998d0,pmae = .510998902d0)
10842 parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
10843 integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo, &
10844 &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor, &
10845 &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb, &
10846 &imc,imtr,iorg,iout, &
10847 &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires, &
10848 &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw, &
10849 &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox, &
10850 &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo, &
10851 &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx, &
10852 &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr, &
10853 &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew, &
10854 &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr, &
10855 &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
10856 double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu, &
10857 &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
10858 &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft, &
10859 &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
10860 &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign, &
10861 &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum, &
10862 &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
10863 &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph, &
10864 &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
10865 &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel, &
10866 &acdipph
10867 real hmal
10868 character*16 bez,bezb,bezr,erbez,bezl
10869 character*80 toptit,sixtit,commen
10870 common/erro/ierro,erbez
10871 common/kons/pi,pi2,pisqrt,rad
10872 common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
10873 common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
10874 common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
10875 common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
10876 common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
10877 common/syos2/rvf(mpa)
10878 common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
10879 &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
10880 common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3), &
10881 &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen, &
10882 &iicav,itionc(nele),ition,idp,ncy,ixcav
10883 common/corcom/dpscor,sigcor,icode,idam,its6d
10884 common/multi/bk0(nele,mmul),ak0(nele,mmul), &
10885 &bka(nele,mmul),aka(nele,mmul)
10886 common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
10887 common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
10888 common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz), &
10889 &tilts(nblz),mout2,icext(nblz),icextal(nblz)
10890 common/beo /aper(2),di0(2),dip0(2),ta(6,6)
10891 common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
10892 &iout
10893 common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
10894 common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint, &
10895 &ntco,eui,euii,nlin,bezl(nele)
10896 common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2), &
10897 &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr, &
10898 &ncororb(nele)
10899 common/apert/apx(nele),apz(nele),ape(3,nele)
10900 common/clos/sigma0(2),iclo,ncorru,ncorrep
10901 common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20), &
10902 &ratioe(nele),iratioe(nele),icoe
10903 common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
10904 common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
10905 common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
10906 common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
10907 common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2, &
10908 &nstart,nstop,iskip,iconv,imad
10909 common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
10910 common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
10911 common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
10912 common/ripp2/nrturn
10913 common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
10914 common/pawc/hmal(nplo)
10915 common/tit/sixtit,commen,ithick
10916 common/co6d/clo6(3),clop6(3)
10917 common/dkic/dki(nele,3)
10918 common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb), &
10919 &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart), &
10920 &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar, &
10921 &nbeam,ibbc,ibeco,ibtyp,lhc
10922 common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
10923 common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
10924 common/wireco/ wirel(nele)
10925 common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele), &
10926 &nturn3(nele), nturn4(nele)
10927 integer idz,itra
10928 double precision al,as,chi0,chid,dp1,dps,exz,sigm
10929 common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa), &
10930 &dps(mpa),idz(2)
10931 common/anf/chi0,chid,exz(2,6),dp1,itra
10932 integer ichrom,is
10933 double precision alf0,amp,bet0,clo,clop,cro,x,y
10934 common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
10935 common/chrom/cro(2),is(2),ichrom
10936 integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
10937 &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
10938 double precision dpmax,preda,weig1,weig2
10939 character*16 coel
10940 common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
10941 common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
10942 common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
10943 &coel(10)
10944 double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
10945 &zsi
10946 real tlim,time0,time1
10947 common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz), &
10948 &aai(nblz,mmul),bbi(nblz,mmul)
10949 common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
10950 common/damp/damp,ampt
10951 common/ttime/tlim,time0,time1
10952 double precision tasm
10953 common/tasm/tasm(6,6)
10954 integer iv,ixv,nlostp,nms,numxv
10955 double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
10956 &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
10957 &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl, &
10958 &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
10959 &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv, &
10960 &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas, &
10961 &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
10962 &zsiv,zsv
10963 logical pstop
10964 common/main1/ &
10965 &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz), &
10966 &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz), &
10967 &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2), &
10968 &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart), &
10969 &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart), &
10970 &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart), &
10971 &xlv(npart),zlv(npart),pstop(npart),rvv(npart), &
10972 &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
10973 common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart), &
10974 &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart), &
10975 &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart), &
10976 &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart), &
10977 &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart), &
10978 &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
10979 &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
10980 &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart), &
10981 &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
10982 common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo), &
10983 &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart), &
10984 &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6), &
10985 &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
10986 integer numx
10987 double precision e0f
10988 common/main4/ e0f,numx
10989 integer ktrack,nwri
10990 double precision dpsv1,strack,strackc,stracks
10991 common/track/ ktrack(nblz),strack(nblz),strackc(nblz), &
10992 &stracks(nblz),dpsv1(npart),nwri
10993 double precision cc,xlim,ylim
10994 parameter(cc = 1.12837916709551d0)
10995 parameter(xlim = 5.33d0)
10996 parameter(ylim = 4.29d0)
10997 dimension crkveb(npart),cikveb(npart),rho2b(npart),tkb(npart), &
10998 &r2b(npart),rb(npart),rkb(npart), &
10999 &xrb(npart),zrb(npart),xbb(npart),zbb(npart),crxb(npart), &
11000 &crzb(npart),cbxb(npart),cbzb(npart)
11001 dimension nbeaux(nbb)
11002 save
11003 !-----------------------------------------------------------------------
11004 do 5 i=1,npart
11005 nlostp(i)=i
11006 5 continue
11007 do 10 i=1,nblz
11008 ktrack(i)=0
11009 strack(i)=zero
11010 strackc(i)=zero
11011 stracks(i)=zero
11012 10 continue
11013 !--beam-beam element
11014 if(nbeam.ge.1) then
11015 do 15 i=1,nbb
11016 nbeaux(i)=0
11017 15 continue
11018 do i=1,iu
11019 ix=ic(i)
11020 if(ix.gt.nblo) then
11021 ix=ix-nblo
11022 if(kz(ix).eq.20.and.parbe(ix,2).eq.0) then
11023 !--round beam
11024 if(sigman(1,imbb(i)).eq.sigman(2,imbb(i))) then
11025 if(nbeaux(imbb(i)).eq.2.or.nbeaux(imbb(i)).eq.3) then
11026 call prror(89)
11027 else
11028 nbeaux(imbb(i))=1
11029 sigman2(1,imbb(i))=sigman(1,imbb(i))**2
11030 endif
11031 endif
11032 !--elliptic beam x>z
11033 if(sigman(1,imbb(i)).gt.sigman(2,imbb(i))) then
11034 if(nbeaux(imbb(i)).eq.1.or.nbeaux(imbb(i)).eq.3) then
11035 call prror(89)
11036 else
11037 nbeaux(imbb(i))=2
11038 sigman2(1,imbb(i))=sigman(1,imbb(i))**2
11039 sigman2(2,imbb(i))=sigman(2,imbb(i))**2
11040 sigmanq(1,imbb(i))=sigman(1,imbb(i))/sigman(2,imbb(i))
11041 sigmanq(2,imbb(i))=sigman(2,imbb(i))/sigman(1,imbb(i))
11042 endif
11043 endif
11044 !--elliptic beam z>x
11045 if(sigman(1,imbb(i)).lt.sigman(2,imbb(i))) then
11046 if(nbeaux(imbb(i)).eq.1.or.nbeaux(imbb(i)).eq.2) then
11047 call prror(89)
11048 else
11049 nbeaux(imbb(i))=3
11050 sigman2(1,imbb(i))=sigman(1,imbb(i))**2
11051 sigman2(2,imbb(i))=sigman(2,imbb(i))**2
11052 sigmanq(1,imbb(i))=sigman(1,imbb(i))/sigman(2,imbb(i))
11053 sigmanq(2,imbb(i))=sigman(2,imbb(i))/sigman(1,imbb(i))
11054 endif
11055 endif
11056 endif
11057 endif
11058 enddo
11059 endif
11060 do 290 i=1,iu
11061 if(mout2.eq.1.and.i.eq.1) call write4
11062 ix=ic(i)
11063 if(ix.gt.nblo) goto 30
11064 ktrack(i)=1
11065 do 20 jb=1,mel(ix)
11066 jx=mtyp(ix,jb)
11067 strack(i)=strack(i)+el(jx)
11068 20 continue
11069 if(abs(strack(i)).le.pieni) ktrack(i)=31
11070 goto 290
11071 30 ix=ix-nblo
11072 kpz=abs(kp(ix))
11073 if(kpz.eq.6) then
11074 ktrack(i)=2
11075 goto 290
11076 endif
11077 40 kzz=kz(ix)
11078 if(kzz.eq.0) then
11079 ktrack(i)=31
11080 goto 290
11081 endif
11082 !--beam-beam element
11083 if(kzz.eq.20.and.nbeam.ge.1.and.parbe(ix,2).eq.0) then
11084 strack(i)=crad*ptnfac(ix)
11085 if(abs(strack(i)).le.pieni) then
11086 ktrack(i)=31
11087 goto 290
11088 endif
11089 if(nbeaux(imbb(i)).eq.1) then
11090 ktrack(i)=41
11091 if(ibeco.eq.1) then
11092 do 42 j=1,napx
11093 if(ibbc.eq.0) then
11094 crkveb(j)=ed(ix)
11095 cikveb(j)=ek(ix)
11096 else
11097 crkveb(j)=ed(ix)*bbcu(imbb(i),11)+ &
11098 &ek(ix)*bbcu(imbb(i),12)
11099 cikveb(j)=-ed(ix)*bbcu(imbb(i),12)+ &
11100 &ek(ix)*bbcu(imbb(i),11)
11101 endif
11102 rho2b(j)=crkveb(j)*crkveb(j)+cikveb(j)*cikveb(j)
11103 if(rho2b(j).le.pieni) &
11104 &goto 42
11105 tkb(j)=rho2b(j)/(two*sigman2(1,imbb(i)))
11106 beamoff(4,imbb(i))=strack(i)*crkveb(j)/rho2b(j)* &
11107 &(one-exp(-tkb(j)))
11108 beamoff(5,imbb(i))=strack(i)*cikveb(j)/rho2b(j)* &
11109 &(one-exp(-tkb(j)))
11110 42 continue
11111 endif
11112 endif
11113 if(nbeaux(imbb(i)).eq.2) then
11114 ktrack(i)=42
11115 if(ibeco.eq.1) then
11116 if(ibtyp.eq.0) then
11117 do j=1,napx
11118 r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
11119 rb(j)=sqrt(r2b(j))
11120 rkb(j)=strack(i)*pisqrt/rb(j)
11121 if(ibbc.eq.0) then
11122 crkveb(j)=ed(ix)
11123 cikveb(j)=ek(ix)
11124 else
11125 crkveb(j)=ed(ix)*bbcu(imbb(i),11)+ &
11126 &ek(ix)*bbcu(imbb(i),12)
11127 cikveb(j)=-ed(ix)*bbcu(imbb(i),12)+ &
11128 &ek(ix)*bbcu(imbb(i),11)
11129 endif
11130 xrb(j)=abs(crkveb(j))/rb(j)
11131 zrb(j)=abs(cikveb(j))/rb(j)
11132 call errf(xrb(j),zrb(j),crxb(j),crzb(j))
11133 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
11134 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
11135 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
11136 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
11137 call errf(xbb(j),zbb(j),cbxb(j),cbzb(j))
11138 beamoff(4,imbb(i))=rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
11139 &sign(one,crkveb(j))
11140 beamoff(5,imbb(i))=rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
11141 &sign(one,cikveb(j))
11142 enddo
11143 else if(ibtyp.eq.1) then
11144 do j=1,napx
11145 r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
11146 rb(j)=sqrt(r2b(j))
11147 rkb(j)=strack(i)*pisqrt/rb(j)
11148 if(ibbc.eq.0) then
11149 crkveb(j)=ed(ix)
11150 cikveb(j)=ek(ix)
11151 else
11152 crkveb(j)=ed(ix)*bbcu(imbb(i),11)+ &
11153 &ek(ix)*bbcu(imbb(i),12)
11154 cikveb(j)=-ed(ix)*bbcu(imbb(i),12)+ &
11155 &ek(ix)*bbcu(imbb(i),11)
11156 endif
11157 xrb(j)=abs(crkveb(j))/rb(j)
11158 zrb(j)=abs(cikveb(j))/rb(j)
11159 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
11160 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
11161 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
11162 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
11163 enddo
11164 call wzsubv(napx,xrb(1),zrb(1),crxb(1),crzb(1))
11165 call wzsubv(napx,xbb(1),zbb(1),cbxb(1),cbzb(1))
11166 do j=1,napx
11167 beamoff(4,imbb(i))=rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
11168 &sign(one,crkveb(j))
11169 beamoff(5,imbb(i))=rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
11170 &sign(one,cikveb(j))
11171 enddo
11172 endif
11173 endif
11174 endif
11175 if(nbeaux(imbb(i)).eq.3) then
11176 ktrack(i)=43
11177 if(ibeco.eq.1) then
11178 if(ibtyp.eq.0) then
11179 do j=1,napx
11180 r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
11181 rb(j)=sqrt(r2b(j))
11182 rkb(j)=strack(i)*pisqrt/rb(j)
11183 if(ibbc.eq.0) then
11184 crkveb(j)=ed(ix)
11185 cikveb(j)=ek(ix)
11186 else
11187 crkveb(j)=ed(ix)*bbcu(imbb(i),11)+ &
11188 &ek(ix)*bbcu(imbb(i),12)
11189 cikveb(j)=-ed(ix)*bbcu(imbb(i),12)+ &
11190 &ek(ix)*bbcu(imbb(i),11)
11191 endif
11192 xrb(j)=abs(crkveb(j))/rb(j)
11193 zrb(j)=abs(cikveb(j))/rb(j)
11194 call errf(zrb(j),xrb(j),crzb(j),crxb(j))
11195 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
11196 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
11197 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
11198 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
11199 call errf(zbb(j),xbb(j),cbzb(j),cbxb(j))
11200 beamoff(4,imbb(i))=rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
11201 &sign(one,crkveb(j))
11202 beamoff(5,imbb(i))=rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
11203 &sign(one,cikveb(j))
11204 enddo
11205 else if(ibtyp.eq.1) then
11206 do j=1,napx
11207 r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
11208 rb(j)=sqrt(r2b(j))
11209 rkb(j)=strack(i)*pisqrt/rb(j)
11210 if(ibbc.eq.0) then
11211 crkveb(j)=ed(ix)
11212 cikveb(j)=ek(ix)
11213 else
11214 crkveb(j)=ed(ix)*bbcu(imbb(i),11)+ &
11215 &ek(ix)*bbcu(imbb(i),12)
11216 cikveb(j)=-ed(ix)*bbcu(imbb(i),12)+ &
11217 &ek(ix)*bbcu(imbb(i),11)
11218 endif
11219 xrb(j)=abs(crkveb(j))/rb(j)
11220 zrb(j)=abs(cikveb(j))/rb(j)
11221 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
11222 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
11223 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
11224 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
11225 enddo
11226 call wzsubv(napx,zrb(1),xrb(1),crzb(1),crxb(1))
11227 call wzsubv(napx,zbb(1),xbb(1),cbzb(1),cbxb(1))
11228 do j=1,napx
11229 beamoff(4,imbb(i))=rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
11230 &sign(one,crkveb(j))
11231 beamoff(5,imbb(i))=rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
11232 &sign(one,cikveb(j))
11233 enddo
11234 endif
11235 endif
11236 endif
11237 goto 290
11238 !--Hirata's 6D beam-beam kick
11239 else if(kzz.eq.20.and.parbe(ix,2).gt.0) then
11240 ktrack(i)=44
11241 parbe(ix,4)=-crad*ptnfac(ix)*half*c1m6
11242 if(ibeco.eq.1) then
11243 track6d(1,1)=ed(ix)*c1m3
11244 track6d(2,1)=zero
11245 track6d(3,1)=ek(ix)*c1m3
11246 track6d(4,1)=zero
11247 track6d(5,1)=zero
11248 track6d(6,1)=zero
11249 napx0=napx
11250 napx=1
11251 call beamint(napx,track6d,parbe,sigz,bbcu,imbb(i),ix,ibtyp, &
11252 &ibbc)
11253 beamoff(1,imbb(i))=track6d(1,1)*c1e3
11254 beamoff(2,imbb(i))=track6d(3,1)*c1e3
11255 beamoff(4,imbb(i))=track6d(2,1)*c1e3
11256 beamoff(5,imbb(i))=track6d(4,1)*c1e3
11257 beamoff(6,imbb(i))=track6d(6,1)
11258 napx=napx0
11259 endif
11260 goto 290
11261 endif
11262 if(kzz.eq.15) then
11263 ktrack(i)=45
11264 goto 290
11265 endif
11266 if(kzz.eq.16) then
11267 ktrack(i)=51
11268 goto 290
11269 else if(kzz.eq.-16) then
11270 ktrack(i)=52
11271 goto 290
11272 endif
11273 if(kzz.eq.22) then
11274 ktrack(i)=3
11275 goto 290
11276 endif
11277 if(mout2.eq.1.and.icextal(i).ne.0) then
11278 write(27,'(a16,2x,1p,2d14.6,d17.9)') bez(ix),extalign(i,1), &
11279 &extalign(i,2),extalign(i,3)
11280 endif
11281 if(kzz.lt.0) goto 180
11282 goto(50,60,70,80,90,100,110,120,130,140,150),kzz
11283 ktrack(i)=31
11284 goto 290
11285 50 if(abs(smiv(1,i)).le.pieni) then
11286 ktrack(i)=31
11287 goto 290
11288 endif
11289 ktrack(i)=11
11290 strack(i)=smiv(1,i)*c1e3
11291 strackc(i)=strack(i)*tiltc(i)
11292 stracks(i)=strack(i)*tilts(i)
11293 goto 290
11294 60 if(abs(smiv(1,i)).le.pieni.and.abs(ramp(ix)).le.pieni) then
11295 ktrack(i)=31
11296 goto 290
11297 endif
11298 ktrack(i)=12
11299 strack(i)=smiv(1,i)
11300 strackc(i)=strack(i)*tiltc(i)
11301 stracks(i)=strack(i)*tilts(i)
11302 goto 290
11303 70 if(abs(smiv(1,i)).le.pieni) then
11304 ktrack(i)=31
11305 goto 290
11306 endif
11307 ktrack(i)=13
11308 strack(i)=smiv(1,i)*c1m3
11309 strackc(i)=strack(i)*tiltc(i)
11310 stracks(i)=strack(i)*tilts(i)
11311 goto 290
11312 80 if(abs(smiv(1,i)).le.pieni) then
11313 ktrack(i)=31
11314 goto 290
11315 endif
11316 ktrack(i)=14
11317 strack(i)=smiv(1,i)*c1m6
11318 strackc(i)=strack(i)*tiltc(i)
11319 stracks(i)=strack(i)*tilts(i)
11320 goto 290
11321 90 if(abs(smiv(1,i)).le.pieni) then
11322 ktrack(i)=31
11323 goto 290
11324 endif
11325 ktrack(i)=15
11326 strack(i)=smiv(1,i)*c1m9
11327 strackc(i)=strack(i)*tiltc(i)
11328 stracks(i)=strack(i)*tilts(i)
11329 goto 290
11330 100 if(abs(smiv(1,i)).le.pieni) then
11331 ktrack(i)=31
11332 goto 290
11333 endif
11334 ktrack(i)=16
11335 strack(i)=smiv(1,i)*c1m12
11336 strackc(i)=strack(i)*tiltc(i)
11337 stracks(i)=strack(i)*tilts(i)
11338 goto 290
11339 110 if(abs(smiv(1,i)).le.pieni) then
11340 ktrack(i)=31
11341 goto 290
11342 endif
11343 ktrack(i)=17
11344 strack(i)=smiv(1,i)*c1m15
11345 strackc(i)=strack(i)*tiltc(i)
11346 stracks(i)=strack(i)*tilts(i)
11347 goto 290
11348 120 if(abs(smiv(1,i)).le.pieni) then
11349 ktrack(i)=31
11350 goto 290
11351 endif
11352 ktrack(i)=18
11353 strack(i)=smiv(1,i)*c1m18
11354 strackc(i)=strack(i)*tiltc(i)
11355 stracks(i)=strack(i)*tilts(i)
11356 goto 290
11357 130 if(abs(smiv(1,i)).le.pieni) then
11358 ktrack(i)=31
11359 goto 290
11360 endif
11361 ktrack(i)=19
11362 strack(i)=smiv(1,i)*c1m21
11363 strackc(i)=strack(i)*tiltc(i)
11364 stracks(i)=strack(i)*tilts(i)
11365 goto 290
11366 140 if(abs(smiv(1,i)).le.pieni) then
11367 ktrack(i)=31
11368 goto 290
11369 endif
11370 ktrack(i)=20
11371 strack(i)=smiv(1,i)*c1m24
11372 strackc(i)=strack(i)*tiltc(i)
11373 stracks(i)=strack(i)*tilts(i)
11374 goto 290
11375 150 r0=ek(ix)
11376 nmz=nmu(ix)
11377 if(abs(r0).le.pieni.or.nmz.eq.0) then
11378 if(abs(dki(ix,1)).le.pieni.and.abs(dki(ix,2)).le.pieni) then
11379 ktrack(i)=31
11380 else if(abs(dki(ix,1)).gt.pieni.and.abs(dki(ix,2)).le.pieni) &
11381 &then
11382 if(abs(dki(ix,3)).gt.pieni) then
11383 ktrack(i)=33
11384 strack(i)=dki(ix,1)/dki(ix,3)
11385 strackc(i)=strack(i)*tiltc(i)
11386 stracks(i)=strack(i)*tilts(i)
11387 else
11388 ktrack(i)=35
11389 strack(i)=dki(ix,1)
11390 strackc(i)=strack(i)*tiltc(i)
11391 stracks(i)=strack(i)*tilts(i)
11392 endif
11393 else if(abs(dki(ix,1)).le.pieni.and.abs(dki(ix,2)).gt.pieni) &
11394 &then
11395 if(abs(dki(ix,3)).gt.pieni) then
11396 ktrack(i)=37
11397 strack(i)=dki(ix,2)/dki(ix,3)
11398 strackc(i)=strack(i)*tiltc(i)
11399 stracks(i)=strack(i)*tilts(i)
11400 else
11401 ktrack(i)=39
11402 strack(i)=dki(ix,2)
11403 strackc(i)=strack(i)*tiltc(i)
11404 stracks(i)=strack(i)*tilts(i)
11405 endif
11406 endif
11407 else
11408 if(abs(dki(ix,1)).le.pieni.and.abs(dki(ix,2)).le.pieni) then
11409 ktrack(i)=32
11410 else if(abs(dki(ix,1)).gt.pieni.and.abs(dki(ix,2)).le.pieni) &
11411 &then
11412 if(abs(dki(ix,3)).gt.pieni) then
11413 ktrack(i)=34
11414 strack(i)=dki(ix,1)/dki(ix,3)
11415 strackc(i)=strack(i)*tiltc(i)
11416 stracks(i)=strack(i)*tilts(i)
11417 else
11418 ktrack(i)=36
11419 strack(i)=dki(ix,1)
11420 strackc(i)=strack(i)*tiltc(i)
11421 stracks(i)=strack(i)*tilts(i)
11422 endif
11423 else if(abs(dki(ix,1)).le.pieni.and.abs(dki(ix,2)).gt.pieni) &
11424 &then
11425 if(abs(dki(ix,3)).gt.pieni) then
11426 ktrack(i)=38
11427 strack(i)=dki(ix,2)/dki(ix,3)
11428 strackc(i)=strack(i)*tiltc(i)
11429 stracks(i)=strack(i)*tilts(i)
11430 else
11431 ktrack(i)=40
11432 strack(i)=dki(ix,2)
11433 strackc(i)=strack(i)*tiltc(i)
11434 stracks(i)=strack(i)*tilts(i)
11435 endif
11436 endif
11437 endif
11438 if(abs(r0).le.pieni.or.nmz.eq.0) goto 290
11439 if(mout2.eq.1) then
11440 benkcc=ed(ix)*benkc(irm(ix))
11441 r0a=one
11442 r000=r0*r00(irm(ix))
11443 do 160 j=1,mmul
11444 fake(1,j)=bbiv(j,1,i)*r0a/benkcc
11445 fake(2,j)=aaiv(j,1,i)*r0a/benkcc
11446 160 r0a=r0a*r000
11447 write(9,'(a16)') bez(ix)
11448 write(9,'(1p,3d23.15)') (fake(1,j), j=1,3)
11449 write(9,'(1p,3d23.15)') (fake(1,j), j=4,6)
11450 write(9,'(1p,3d23.15)') (fake(1,j), j=7,9)
11451 write(9,'(1p,3d23.15)') (fake(1,j), j=10,12)
11452 write(9,'(1p,3d23.15)') (fake(1,j), j=13,15)
11453 write(9,'(1p,3d23.15)') (fake(1,j), j=16,18)
11454 write(9,'(1p,2d23.15)') (fake(1,j), j=19,20)
11455 write(9,'(1p,3d23.15)') (fake(2,j), j=1,3)
11456 write(9,'(1p,3d23.15)') (fake(2,j), j=4,6)
11457 write(9,'(1p,3d23.15)') (fake(2,j), j=7,9)
11458 write(9,'(1p,3d23.15)') (fake(2,j), j=10,12)
11459 write(9,'(1p,3d23.15)') (fake(2,j), j=13,15)
11460 write(9,'(1p,3d23.15)') (fake(2,j), j=16,18)
11461 write(9,'(1p,2d23.15)') (fake(2,j), j=19,20)
11462 do 170 j=1,20
11463 fake(1,j)=zero
11464 170 fake(2,j)=zero
11465 endif
11466 goto 290
11467 180 kzz=-kzz
11468 goto(190,200,210,220,230,240,250,260,270,280),kzz
11469 ktrack(i)=31
11470 goto 290
11471 190 if(abs(smiv(1,i)).le.pieni) then
11472 ktrack(i)=31
11473 goto 290
11474 endif
11475 ktrack(i)=21
11476 strack(i)=smiv(1,i)*c1e3
11477 strackc(i)=strack(i)*tiltc(i)
11478 stracks(i)=strack(i)*tilts(i)
11479 goto 290
11480 200 if(abs(smiv(1,i)).le.pieni) then
11481 ktrack(i)=31
11482 goto 290
11483 endif
11484 ktrack(i)=22
11485 strack(i)=smiv(1,i)
11486 strackc(i)=strack(i)*tiltc(i)
11487 stracks(i)=strack(i)*tilts(i)
11488 goto 290
11489 210 if(abs(smiv(1,i)).le.pieni) then
11490 ktrack(i)=31
11491 goto 290
11492 endif
11493 ktrack(i)=23
11494 strack(i)=smiv(1,i)*c1m3
11495 strackc(i)=strack(i)*tiltc(i)
11496 stracks(i)=strack(i)*tilts(i)
11497 goto 290
11498 220 if(abs(smiv(1,i)).le.pieni) then
11499 ktrack(i)=31
11500 goto 290
11501 endif
11502 ktrack(i)=24
11503 strack(i)=smiv(1,i)*c1m6
11504 strackc(i)=strack(i)*tiltc(i)
11505 stracks(i)=strack(i)*tilts(i)
11506 goto 290
11507 230 if(abs(smiv(1,i)).le.pieni) then
11508 ktrack(i)=31
11509 goto 290
11510 endif
11511 ktrack(i)=25
11512 strack(i)=smiv(1,i)*c1m9
11513 strackc(i)=strack(i)*tiltc(i)
11514 stracks(i)=strack(i)*tilts(i)
11515 goto 290
11516 240 if(abs(smiv(1,i)).le.pieni) then
11517 ktrack(i)=31
11518 goto 290
11519 endif
11520 ktrack(i)=26
11521 strack(i)=smiv(1,i)*c1m12
11522 strackc(i)=strack(i)*tiltc(i)
11523 stracks(i)=strack(i)*tilts(i)
11524 goto 290
11525 250 if(abs(smiv(1,i)).le.pieni) then
11526 ktrack(i)=31
11527 goto 290
11528 endif
11529 ktrack(i)=27
11530 strack(i)=smiv(1,i)*c1m15
11531 strackc(i)=strack(i)*tiltc(i)
11532 stracks(i)=strack(i)*tilts(i)
11533 goto 290
11534 260 if(abs(smiv(1,i)).le.pieni) then
11535 ktrack(i)=31
11536 goto 290
11537 endif
11538 ktrack(i)=28
11539 strack(i)=smiv(1,i)*c1m18
11540 strackc(i)=strack(i)*tiltc(i)
11541 stracks(i)=strack(i)*tilts(i)
11542 goto 290
11543 270 if(abs(smiv(1,i)).le.pieni) then
11544 ktrack(i)=31
11545 goto 290
11546 endif
11547 ktrack(i)=29
11548 strack(i)=smiv(1,i)*c1m21
11549 strackc(i)=strack(i)*tiltc(i)
11550 stracks(i)=strack(i)*tilts(i)
11551 goto 290
11552 280 if(abs(smiv(1,i)).le.pieni) then
11553 ktrack(i)=31
11554 goto 290
11555 endif
11556 ktrack(i)=30
11557 strack(i)=smiv(1,i)*c1m24
11558 strackc(i)=strack(i)*tiltc(i)
11559 stracks(i)=strack(i)*tilts(i)
11560 290 continue
11561 do 300 j=1,napx
11562 dpsv1(j)=dpsv(j)*c1e3/(one+dpsv(j))
11563 300 continue
11564 nwri=nwr(3)
11565 if(nwri.eq.0) nwri=numl+numlr+1
11566 if(idp.eq.0.or.ition.eq.0) then
11567 call thck4d(nthinerr)
11568 else
11569 hsy(3)=c1m3*hsy(3)*ition
11570 do 310 jj=1,nele
11571 if(kz(jj).eq.12) hsyc(jj)=c1m3*hsyc(jj)*itionc(jj)
11572 310 continue
11573 if(abs(phas).ge.pieni) then
11574 call thck6dua(nthinerr)
11575 else
11576 call thck6d(nthinerr)
11577 endif
11578 endif
11579 return
11580 end
11581 subroutine thck4d(nthinerr)
11582 !-----------------------------------------------------------------------
11583 !
11584 ! TRACK THICK LENS 4D
11585 !
11586 !
11587 ! F. SCHMIDT
11588 !-----------------------------------------------------------------------
11589 implicit none
11590 integer i,idz1,idz2,irrtr,ix,j,k,kpz,n,nmz,nthinerr
11591 double precision cbxb,cbzb,cccc,cikve,cikveb,crkve,crkveb,crkveuk,&
11592 &crxb,crzb,dpsv3,pux,puxve,puzve,r0,r2b,rb,rho2b,rkb,tkb,xbb,xlvj, &
11593 &xrb,yv1j,yv2j,zbb,zlvj,zrb
11594 integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1, &
11595 &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran, &
11596 &nrco,ntr,nzfz
11597 parameter(npart = 64,nmac = 1)
11598 parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000, &
11599 &nzfz = 300000,mmul = 11)
11600 parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5, &
11601 &nema = 15)
11602 parameter(mcor = 10,mcop = mcor+6, mbea = 15)
11603 parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
11604 parameter(nmon1 = 600,ncor1 = 600)
11605 parameter(ntr = 20,nbb = 160)
11606 integer ireturn, xory, nac, nfree, nramp1,nplato, nramp2
11607 double precision e0fo,e0o,xv1j,xv2j
11608 double precision acdipamp, qd, acphase, acdipamp2, &
11609 &acdipamp1
11610 double precision l,cur,dx,dy,tx,ty,embl,leff,rx,ry,lin,chi,xi,yi
11611 logical llost
11612 double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3, &
11613 &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21, &
11614 &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
11615 &one,pieni,pmae,pmap,three,two,zero
11616 parameter(pieni = 1d-38)
11617 parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
11618 parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
11619 parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
11620 parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
11621 parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 = &
11622 &1.0d16)
11623 parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
11624 parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
11625 parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
11626 parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
11627 parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
11628 parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
11629 parameter(pmap = 938.271998d0,pmae = .510998902d0)
11630 parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
11631 integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo, &
11632 &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor, &
11633 &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb, &
11634 &imc,imtr,iorg,iout, &
11635 &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires, &
11636 &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw, &
11637 &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox, &
11638 &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo, &
11639 &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx, &
11640 &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr, &
11641 &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew, &
11642 &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr, &
11643 &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
11644 double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu, &
11645 &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
11646 &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft, &
11647 &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
11648 &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign, &
11649 &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum, &
11650 &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
11651 &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph, &
11652 &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
11653 &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel, &
11654 &acdipph
11655 real hmal
11656 character*16 bez,bezb,bezr,erbez,bezl
11657 character*80 toptit,sixtit,commen
11658 common/erro/ierro,erbez
11659 common/kons/pi,pi2,pisqrt,rad
11660 common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
11661 common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
11662 common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
11663 common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
11664 common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
11665 common/syos2/rvf(mpa)
11666 common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
11667 &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
11668 common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3), &
11669 &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen, &
11670 &iicav,itionc(nele),ition,idp,ncy,ixcav
11671 common/corcom/dpscor,sigcor,icode,idam,its6d
11672 common/multi/bk0(nele,mmul),ak0(nele,mmul), &
11673 &bka(nele,mmul),aka(nele,mmul)
11674 common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
11675 common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
11676 common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz), &
11677 &tilts(nblz),mout2,icext(nblz),icextal(nblz)
11678 common/beo /aper(2),di0(2),dip0(2),ta(6,6)
11679 common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
11680 &iout
11681 common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
11682 common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint, &
11683 &ntco,eui,euii,nlin,bezl(nele)
11684 common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2), &
11685 &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr, &
11686 &ncororb(nele)
11687 common/apert/apx(nele),apz(nele),ape(3,nele)
11688 common/clos/sigma0(2),iclo,ncorru,ncorrep
11689 common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20), &
11690 &ratioe(nele),iratioe(nele),icoe
11691 common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
11692 common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
11693 common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
11694 common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
11695 common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2, &
11696 &nstart,nstop,iskip,iconv,imad
11697 common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
11698 common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
11699 common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
11700 common/ripp2/nrturn
11701 common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
11702 common/pawc/hmal(nplo)
11703 common/tit/sixtit,commen,ithick
11704 common/co6d/clo6(3),clop6(3)
11705 common/dkic/dki(nele,3)
11706 common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb), &
11707 &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart), &
11708 &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar, &
11709 &nbeam,ibbc,ibeco,ibtyp,lhc
11710 common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
11711 common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
11712 common/wireco/ wirel(nele)
11713 common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele), &
11714 &nturn3(nele), nturn4(nele)
11715 integer idz,itra
11716 double precision al,as,chi0,chid,dp1,dps,exz,sigm
11717 common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa), &
11718 &dps(mpa),idz(2)
11719 common/anf/chi0,chid,exz(2,6),dp1,itra
11720 integer ichrom,is
11721 double precision alf0,amp,bet0,clo,clop,cro,x,y
11722 common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
11723 common/chrom/cro(2),is(2),ichrom
11724 integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
11725 &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
11726 double precision dpmax,preda,weig1,weig2
11727 character*16 coel
11728 common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
11729 common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
11730 common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
11731 &coel(10)
11732 double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
11733 &zsi
11734 real tlim,time0,time1
11735 common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz), &
11736 &aai(nblz,mmul),bbi(nblz,mmul)
11737 common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
11738 common/damp/damp,ampt
11739 common/ttime/tlim,time0,time1
11740 double precision tasm
11741 common/tasm/tasm(6,6)
11742 integer iv,ixv,nlostp,nms,numxv
11743 double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
11744 &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
11745 &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl, &
11746 &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
11747 &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv, &
11748 &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas, &
11749 &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
11750 &zsiv,zsv
11751 logical pstop
11752 common/main1/ &
11753 &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz), &
11754 &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz), &
11755 &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2), &
11756 &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart), &
11757 &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart), &
11758 &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart), &
11759 &xlv(npart),zlv(npart),pstop(npart),rvv(npart), &
11760 &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
11761 common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart), &
11762 &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart), &
11763 &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart), &
11764 &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart), &
11765 &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart), &
11766 &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
11767 &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
11768 &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart), &
11769 &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
11770 common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo), &
11771 &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart), &
11772 &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6), &
11773 &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
11774 integer numx
11775 double precision e0f
11776 common/main4/ e0f,numx
11777 integer ktrack,nwri
11778 double precision dpsv1,strack,strackc,stracks
11779 common/track/ ktrack(nblz),strack(nblz),strackc(nblz), &
11780 &stracks(nblz),dpsv1(npart),nwri
11781 double precision cc,xlim,ylim
11782 parameter(cc = 1.12837916709551d0)
11783 parameter(xlim = 5.33d0)
11784 parameter(ylim = 4.29d0)
11785 dimension crkveb(npart),cikveb(npart),rho2b(npart),tkb(npart), &
11786 &r2b(npart),rb(npart),rkb(npart), &
11787 &xrb(npart),zrb(npart),xbb(npart),zbb(npart),crxb(npart), &
11788 &crzb(npart),cbxb(npart),cbzb(npart)
11789 dimension dpsv3(npart)
11790 save
11791 !-----------------------------------------------------------------------
11792 nthinerr=0
11793 idz1=idz(1)
11794 idz2=idz(2)
11795 do 490 n=1,numl
11796 numx=n-1
11797 if(irip.eq.1) call ripple(n)
11798 if(mod(numx,nwri).eq.0) call writebin(nthinerr)
11799 if(nthinerr.ne.0) return
11800 do 480 i=1,iu
11801 if(ktrack(i).eq.1) then
11802 ix=ic(i)
11803 else
11804 ix=ic(i)-nblo
11805 endif
11806 if(i.eq.1103) then
11807 endif
11808 !----------count=43
11809 goto(20,480,740,480,480,480,480,480,480,480,40,60,80,100, &
11810 &120,140,160,180,200,220,270,290,310,330,350,370,390,410, &
11811 &430,450,470,240,500,520,540,560,580,600,620,640,680,700 &
11812 &,720,480,748,480,480,480,480,480,745,746),ktrack(i)
11813 goto 480
11814 20 do 30 j=1,napx
11815 puxve=xv(1,j)
11816 puzve=yv(1,j)
11817 xv(1,j)=bl1v(1,1,j,ix)*puxve+bl1v(2,1,j,ix)*puzve+ idz1 &
11818 &*bl1v(5,1,j,ix)*dpsv(j)*c1e3
11819 yv(1,j)=bl1v(3,1,j,ix)*puxve+bl1v(4,1,j,ix)*puzve+ idz1 &
11820 &*bl1v(6,1,j,ix)*dpsv(j)*c1e3
11821 puxve=xv(2,j)
11822 puzve=yv(2,j)
11823 xv(2,j)=bl1v(1,2,j,ix)*puxve+bl1v(2,2,j,ix)*puzve+ idz2 &
11824 &*bl1v(5,2,j,ix)*dpsv(j)*c1e3
11825 yv(2,j)=bl1v(3,2,j,ix)*puxve+bl1v(4,2,j,ix)*puzve+ idz2 &
11826 &*bl1v(6,2,j,ix)*dpsv(j)*c1e3
11827 30 continue
11828 goto 480
11829 !--HORIZONTAL DIPOLE
11830 40 do 50 j=1,napx
11831 yv(1,j)=yv(1,j)+strackc(i)*oidpsv(j)
11832 yv(2,j)=yv(2,j)+stracks(i)*oidpsv(j)
11833 50 continue
11834 goto 470
11835 !--NORMAL QUADRUPOLE
11836 60 do 70 j=1,napx
11837 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
11838 &(xv(2,j)-zsiv(1,i))*tilts(i)
11839 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
11840 &(xv(2,j)-zsiv(1,i))*tiltc(i)
11841 crkve=xlv(j)
11842 cikve=zlv(j)
11843 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
11844 &stracks(i)*cikve)
11845 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
11846 &stracks(i)*crkve)
11847 70 continue
11848 goto 470
11849 !--NORMAL SEXTUPOLE
11850 80 do 90 j=1,napx
11851 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
11852 &(xv(2,j)-zsiv(1,i))*tilts(i)
11853 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
11854 &(xv(2,j)-zsiv(1,i))*tiltc(i)
11855 crkve=xlv(j)
11856 cikve=zlv(j)
11857 crkveuk=crkve*xlv(j)-cikve*zlv(j)
11858 cikve=crkve*zlv(j)+cikve*xlv(j)
11859 crkve=crkveuk
11860 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
11861 &stracks(i)*cikve)
11862 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
11863 &stracks(i)*crkve)
11864 90 continue
11865 goto 470
11866 !--NORMAL OCTUPOLE
11867 100 do 110 j=1,napx
11868 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
11869 &(xv(2,j)-zsiv(1,i))*tilts(i)
11870 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
11871 &(xv(2,j)-zsiv(1,i))*tiltc(i)
11872 crkve=xlv(j)
11873 cikve=zlv(j)
11874 crkveuk=crkve*xlv(j)-cikve*zlv(j)
11875 cikve=crkve*zlv(j)+cikve*xlv(j)
11876 crkve=crkveuk
11877 crkveuk=crkve*xlv(j)-cikve*zlv(j)
11878 cikve=crkve*zlv(j)+cikve*xlv(j)
11879 crkve=crkveuk
11880 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
11881 &stracks(i)*cikve)
11882 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
11883 &stracks(i)*crkve)
11884 110 continue
11885 goto 470
11886 !--NORMAL DECAPOLE
11887 120 do 130 j=1,napx
11888 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
11889 &(xv(2,j)-zsiv(1,i))*tilts(i)
11890 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
11891 &(xv(2,j)-zsiv(1,i))*tiltc(i)
11892 crkve=xlv(j)
11893 cikve=zlv(j)
11894 crkveuk=crkve*xlv(j)-cikve*zlv(j)
11895 cikve=crkve*zlv(j)+cikve*xlv(j)
11896 crkve=crkveuk
11897 crkveuk=crkve*xlv(j)-cikve*zlv(j)
11898 cikve=crkve*zlv(j)+cikve*xlv(j)
11899 crkve=crkveuk
11900 crkveuk=crkve*xlv(j)-cikve*zlv(j)
11901 cikve=crkve*zlv(j)+cikve*xlv(j)
11902 crkve=crkveuk
11903 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
11904 &stracks(i)*cikve)
11905 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
11906 &stracks(i)*crkve)
11907 130 continue
11908 goto 470
11909 !--NORMAL DODECAPOLE
11910 140 do 150 j=1,napx
11911 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
11912 &(xv(2,j)-zsiv(1,i))*tilts(i)
11913 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
11914 &(xv(2,j)-zsiv(1,i))*tiltc(i)
11915 crkve=xlv(j)
11916 cikve=zlv(j)
11917 crkveuk=crkve*xlv(j)-cikve*zlv(j)
11918 cikve=crkve*zlv(j)+cikve*xlv(j)
11919 crkve=crkveuk
11920 crkveuk=crkve*xlv(j)-cikve*zlv(j)
11921 cikve=crkve*zlv(j)+cikve*xlv(j)
11922 crkve=crkveuk
11923 crkveuk=crkve*xlv(j)-cikve*zlv(j)
11924 cikve=crkve*zlv(j)+cikve*xlv(j)
11925 crkve=crkveuk
11926 crkveuk=crkve*xlv(j)-cikve*zlv(j)
11927 cikve=crkve*zlv(j)+cikve*xlv(j)
11928 crkve=crkveuk
11929 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
11930 &stracks(i)*cikve)
11931 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
11932 &stracks(i)*crkve)
11933 150 continue
11934 goto 470
11935 !--NORMAL 14-POLE
11936 160 do 170 j=1,napx
11937 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
11938 &(xv(2,j)-zsiv(1,i))*tilts(i)
11939 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
11940 &(xv(2,j)-zsiv(1,i))*tiltc(i)
11941 crkve=xlv(j)
11942 cikve=zlv(j)
11943 crkveuk=crkve*xlv(j)-cikve*zlv(j)
11944 cikve=crkve*zlv(j)+cikve*xlv(j)
11945 crkve=crkveuk
11946 crkveuk=crkve*xlv(j)-cikve*zlv(j)
11947 cikve=crkve*zlv(j)+cikve*xlv(j)
11948 crkve=crkveuk
11949 crkveuk=crkve*xlv(j)-cikve*zlv(j)
11950 cikve=crkve*zlv(j)+cikve*xlv(j)
11951 crkve=crkveuk
11952 crkveuk=crkve*xlv(j)-cikve*zlv(j)
11953 cikve=crkve*zlv(j)+cikve*xlv(j)
11954 crkve=crkveuk
11955 crkveuk=crkve*xlv(j)-cikve*zlv(j)
11956 cikve=crkve*zlv(j)+cikve*xlv(j)
11957 crkve=crkveuk
11958 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
11959 &stracks(i)*cikve)
11960 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
11961 &stracks(i)*crkve)
11962 170 continue
11963 goto 470
11964 !--NORMAL 16-POLE
11965 180 do 190 j=1,napx
11966 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
11967 &(xv(2,j)-zsiv(1,i))*tilts(i)
11968 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
11969 &(xv(2,j)-zsiv(1,i))*tiltc(i)
11970 crkve=xlv(j)
11971 cikve=zlv(j)
11972 crkveuk=crkve*xlv(j)-cikve*zlv(j)
11973 cikve=crkve*zlv(j)+cikve*xlv(j)
11974 crkve=crkveuk
11975 crkveuk=crkve*xlv(j)-cikve*zlv(j)
11976 cikve=crkve*zlv(j)+cikve*xlv(j)
11977 crkve=crkveuk
11978 crkveuk=crkve*xlv(j)-cikve*zlv(j)
11979 cikve=crkve*zlv(j)+cikve*xlv(j)
11980 crkve=crkveuk
11981 crkveuk=crkve*xlv(j)-cikve*zlv(j)
11982 cikve=crkve*zlv(j)+cikve*xlv(j)
11983 crkve=crkveuk
11984 crkveuk=crkve*xlv(j)-cikve*zlv(j)
11985 cikve=crkve*zlv(j)+cikve*xlv(j)
11986 crkve=crkveuk
11987 crkveuk=crkve*xlv(j)-cikve*zlv(j)
11988 cikve=crkve*zlv(j)+cikve*xlv(j)
11989 crkve=crkveuk
11990 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
11991 &stracks(i)*cikve)
11992 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
11993 &stracks(i)*crkve)
11994 190 continue
11995 goto 470
11996 !--NORMAL 18-POLE
11997 200 do 210 j=1,napx
11998 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
11999 &(xv(2,j)-zsiv(1,i))*tilts(i)
12000 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
12001 &(xv(2,j)-zsiv(1,i))*tiltc(i)
12002 crkve=xlv(j)
12003 cikve=zlv(j)
12004 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12005 cikve=crkve*zlv(j)+cikve*xlv(j)
12006 crkve=crkveuk
12007 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12008 cikve=crkve*zlv(j)+cikve*xlv(j)
12009 crkve=crkveuk
12010 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12011 cikve=crkve*zlv(j)+cikve*xlv(j)
12012 crkve=crkveuk
12013 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12014 cikve=crkve*zlv(j)+cikve*xlv(j)
12015 crkve=crkveuk
12016 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12017 cikve=crkve*zlv(j)+cikve*xlv(j)
12018 crkve=crkveuk
12019 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12020 cikve=crkve*zlv(j)+cikve*xlv(j)
12021 crkve=crkveuk
12022 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12023 cikve=crkve*zlv(j)+cikve*xlv(j)
12024 crkve=crkveuk
12025 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
12026 &stracks(i)*cikve)
12027 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
12028 &stracks(i)*crkve)
12029 210 continue
12030 goto 470
12031 !--NORMAL 20-POLE
12032 220 do 230 j=1,napx
12033 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
12034 &(xv(2,j)-zsiv(1,i))*tilts(i)
12035 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
12036 &(xv(2,j)-zsiv(1,i))*tiltc(i)
12037 crkve=xlv(j)
12038 cikve=zlv(j)
12039 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12040 cikve=crkve*zlv(j)+cikve*xlv(j)
12041 crkve=crkveuk
12042 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12043 cikve=crkve*zlv(j)+cikve*xlv(j)
12044 crkve=crkveuk
12045 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12046 cikve=crkve*zlv(j)+cikve*xlv(j)
12047 crkve=crkveuk
12048 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12049 cikve=crkve*zlv(j)+cikve*xlv(j)
12050 crkve=crkveuk
12051 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12052 cikve=crkve*zlv(j)+cikve*xlv(j)
12053 crkve=crkveuk
12054 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12055 cikve=crkve*zlv(j)+cikve*xlv(j)
12056 crkve=crkveuk
12057 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12058 cikve=crkve*zlv(j)+cikve*xlv(j)
12059 crkve=crkveuk
12060 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12061 cikve=crkve*zlv(j)+cikve*xlv(j)
12062 crkve=crkveuk
12063 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
12064 &stracks(i)*cikve)
12065 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
12066 &stracks(i)*crkve)
12067 230 continue
12068 goto 470
12069 500 continue
12070 do 510 j=1,napx
12071 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
12072 &(xv(2,j)-zsiv(1,i))*tilts(i)
12073 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
12074 &(xv(2,j)-zsiv(1,i))*tiltc(i)
12075 yv(1,j)=yv(1,j)-(strack(i)*xlvj*oidpsv(j) &
12076 &+dpsv1(j))*dki(ix,1)*tiltc(i) &
12077 &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
12078 yv(2,j)=yv(2,j)-(strack(i)*xlvj*oidpsv(j) &
12079 &+dpsv1(j))*dki(ix,1)*tilts(i) &
12080 &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
12081 510 continue
12082 goto 470
12083 520 continue
12084 do 530 j=1,napx
12085 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
12086 &(xv(2,j)-zsiv(1,i))*tilts(i)
12087 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
12088 &(xv(2,j)-zsiv(1,i))*tiltc(i)
12089 yv(1,j)=yv(1,j)-(strack(i)*xlvj*oidpsv(j) &
12090 &+dpsv1(j))*dki(ix,1)*tiltc(i) &
12091 &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
12092 yv(2,j)=yv(2,j)-(strack(i)*xlvj*oidpsv(j) &
12093 &+dpsv1(j))*dki(ix,1)*tilts(i) &
12094 &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
12095 530 continue
12096 goto 240
12097 540 continue
12098 do 550 j=1,napx
12099 yv(1,j)=yv(1,j)-strackc(i)*dpsv1(j) &
12100 &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
12101 yv(2,j)=yv(2,j)-stracks(i)*dpsv1(j) &
12102 &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
12103 550 continue
12104 goto 470
12105 560 continue
12106 do 570 j=1,napx
12107 yv(1,j)=yv(1,j)-strackc(i)*dpsv1(j) &
12108 &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
12109 yv(2,j)=yv(2,j)-stracks(i)*dpsv1(j) &
12110 &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
12111 570 continue
12112 goto 240
12113 580 continue
12114 do 590 j=1,napx
12115 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
12116 &(xv(2,j)-zsiv(1,i))*tilts(i)
12117 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
12118 &(xv(2,j)-zsiv(1,i))*tiltc(i)
12119 yv(1,j)=yv(1,j)+(strack(i)*zlvj*oidpsv(j) &
12120 &-dpsv1(j))*dki(ix,2)*tilts(i) &
12121 &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
12122 yv(2,j)=yv(2,j)-(strack(i)*zlvj*oidpsv(j) &
12123 &-dpsv1(j))*dki(ix,2)*tiltc(i) &
12124 &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
12125 590 continue
12126 goto 470
12127 600 continue
12128 do 610 j=1,napx
12129 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
12130 &(xv(2,j)-zsiv(1,i))*tilts(i)
12131 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
12132 &(xv(2,j)-zsiv(1,i))*tiltc(i)
12133 yv(1,j)=yv(1,j)+(strack(i)*zlvj*oidpsv(j) &
12134 &-dpsv1(j))*dki(ix,2)*tilts(i) &
12135 &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
12136 yv(2,j)=yv(2,j)-(strack(i)*zlvj*oidpsv(j) &
12137 &-dpsv1(j))*dki(ix,2)*tiltc(i) &
12138 &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
12139 610 continue
12140 goto 240
12141 620 continue
12142 do 630 j=1,napx
12143 yv(1,j)=yv(1,j)-stracks(i)*dpsv1(j) &
12144 &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
12145 yv(2,j)=yv(2,j)+strackc(i)*dpsv1(j) &
12146 &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
12147 630 continue
12148 goto 470
12149 640 continue
12150 do 650 j=1,napx
12151 yv(1,j)=yv(1,j)-stracks(i)*dpsv1(j) &
12152 &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
12153 yv(2,j)=yv(2,j)+strackc(i)*dpsv1(j) &
12154 &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
12155 650 continue
12156 240 r0=ek(ix)
12157 nmz=nmu(ix)
12158 if(nmz.ge.2) then
12159 do 260 j=1,napx
12160 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
12161 &(xv(2,j)-zsiv(1,i))*tilts(i)
12162 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
12163 &(xv(2,j)-zsiv(1,i))*tiltc(i)
12164 yv1j=bbiv(1,1,i)+bbiv(2,1,i)*xlvj+aaiv(2,1,i)*zlvj
12165 yv2j=aaiv(1,1,i)-bbiv(2,1,i)*zlvj+aaiv(2,1,i)*xlvj
12166 crkve=xlvj
12167 cikve=zlvj
12168 do 250 k=3,nmz
12169 crkveuk=crkve*xlvj-cikve*zlvj
12170 cikve=crkve*zlvj+cikve*xlvj
12171 crkve=crkveuk
12172 yv1j=yv1j+bbiv(k,1,i)*crkve+aaiv(k,1,i)*cikve
12173 yv2j=yv2j-bbiv(k,1,i)*cikve+aaiv(k,1,i)*crkve
12174 250 continue
12175 yv(1,j)=yv(1,j)+(tiltc(i)*yv1j-tilts(i)*yv2j)*oidpsv(j)
12176 yv(2,j)=yv(2,j)+(tiltc(i)*yv2j+tilts(i)*yv1j)*oidpsv(j)
12177 260 continue
12178 else
12179 do 265 j=1,napx
12180 yv(1,j)=yv(1,j)+(tiltc(i)*bbiv(1,1,i)- &
12181 &tilts(i)*aaiv(1,1,i))*oidpsv(j)
12182 yv(2,j)=yv(2,j)+(tiltc(i)*aaiv(1,1,i)+ &
12183 &tilts(i)*bbiv(1,1,i))*oidpsv(j)
12184 265 continue
12185 endif
12186 goto 470
12187 !--SKEW ELEMENTS
12188 !--VERTICAL DIPOLE
12189 270 do 280 j=1,napx
12190 yv(1,j)=yv(1,j)-stracks(i)*oidpsv(j)
12191 yv(2,j)=yv(2,j)+strackc(i)*oidpsv(j)
12192 280 continue
12193 goto 470
12194 !--SKEW QUADRUPOLE
12195 290 do 300 j=1,napx
12196 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
12197 &(xv(2,j)-zsiv(1,i))*tilts(i)
12198 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
12199 &(xv(2,j)-zsiv(1,i))*tiltc(i)
12200 crkve=xlv(j)
12201 cikve=zlv(j)
12202 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
12203 &stracks(i)*crkve)
12204 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
12205 &stracks(i)*cikve)
12206 300 continue
12207 goto 470
12208 !--SKEW SEXTUPOLE
12209 310 do 320 j=1,napx
12210 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
12211 &(xv(2,j)-zsiv(1,i))*tilts(i)
12212 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
12213 &(xv(2,j)-zsiv(1,i))*tiltc(i)
12214 crkve=xlv(j)
12215 cikve=zlv(j)
12216 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12217 cikve=crkve*zlv(j)+cikve*xlv(j)
12218 crkve=crkveuk
12219 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
12220 &stracks(i)*crkve)
12221 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
12222 &stracks(i)*cikve)
12223 320 continue
12224 goto 470
12225 !--SKEW OCTUPOLE
12226 330 do 340 j=1,napx
12227 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
12228 &(xv(2,j)-zsiv(1,i))*tilts(i)
12229 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
12230 &(xv(2,j)-zsiv(1,i))*tiltc(i)
12231 crkve=xlv(j)
12232 cikve=zlv(j)
12233 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12234 cikve=crkve*zlv(j)+cikve*xlv(j)
12235 crkve=crkveuk
12236 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12237 cikve=crkve*zlv(j)+cikve*xlv(j)
12238 crkve=crkveuk
12239 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
12240 &stracks(i)*crkve)
12241 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
12242 &stracks(i)*cikve)
12243 340 continue
12244 goto 470
12245 !--SKEW DECAPOLE
12246 350 do 360 j=1,napx
12247 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
12248 &(xv(2,j)-zsiv(1,i))*tilts(i)
12249 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
12250 &(xv(2,j)-zsiv(1,i))*tiltc(i)
12251 crkve=xlv(j)
12252 cikve=zlv(j)
12253 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12254 cikve=crkve*zlv(j)+cikve*xlv(j)
12255 crkve=crkveuk
12256 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12257 cikve=crkve*zlv(j)+cikve*xlv(j)
12258 crkve=crkveuk
12259 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12260 cikve=crkve*zlv(j)+cikve*xlv(j)
12261 crkve=crkveuk
12262 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
12263 &stracks(i)*crkve)
12264 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
12265 &stracks(i)*cikve)
12266 360 continue
12267 goto 470
12268 !--SKEW DODECAPOLE
12269 370 do 380 j=1,napx
12270 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
12271 &(xv(2,j)-zsiv(1,i))*tilts(i)
12272 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
12273 &(xv(2,j)-zsiv(1,i))*tiltc(i)
12274 crkve=xlv(j)
12275 cikve=zlv(j)
12276 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12277 cikve=crkve*zlv(j)+cikve*xlv(j)
12278 crkve=crkveuk
12279 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12280 cikve=crkve*zlv(j)+cikve*xlv(j)
12281 crkve=crkveuk
12282 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12283 cikve=crkve*zlv(j)+cikve*xlv(j)
12284 crkve=crkveuk
12285 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12286 cikve=crkve*zlv(j)+cikve*xlv(j)
12287 crkve=crkveuk
12288 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
12289 &stracks(i)*crkve)
12290 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
12291 &stracks(i)*cikve)
12292 380 continue
12293 goto 470
12294 !--SKEW 14-POLE
12295 390 do 400 j=1,napx
12296 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
12297 &(xv(2,j)-zsiv(1,i))*tilts(i)
12298 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
12299 &(xv(2,j)-zsiv(1,i))*tiltc(i)
12300 crkve=xlv(j)
12301 cikve=zlv(j)
12302 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12303 cikve=crkve*zlv(j)+cikve*xlv(j)
12304 crkve=crkveuk
12305 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12306 cikve=crkve*zlv(j)+cikve*xlv(j)
12307 crkve=crkveuk
12308 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12309 cikve=crkve*zlv(j)+cikve*xlv(j)
12310 crkve=crkveuk
12311 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12312 cikve=crkve*zlv(j)+cikve*xlv(j)
12313 crkve=crkveuk
12314 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12315 cikve=crkve*zlv(j)+cikve*xlv(j)
12316 crkve=crkveuk
12317 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
12318 &stracks(i)*crkve)
12319 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
12320 &stracks(i)*cikve)
12321 400 continue
12322 goto 470
12323 !--SKEW 16-POLE
12324 410 do 420 j=1,napx
12325 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
12326 &(xv(2,j)-zsiv(1,i))*tilts(i)
12327 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
12328 &(xv(2,j)-zsiv(1,i))*tiltc(i)
12329 crkve=xlv(j)
12330 cikve=zlv(j)
12331 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12332 cikve=crkve*zlv(j)+cikve*xlv(j)
12333 crkve=crkveuk
12334 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12335 cikve=crkve*zlv(j)+cikve*xlv(j)
12336 crkve=crkveuk
12337 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12338 cikve=crkve*zlv(j)+cikve*xlv(j)
12339 crkve=crkveuk
12340 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12341 cikve=crkve*zlv(j)+cikve*xlv(j)
12342 crkve=crkveuk
12343 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12344 cikve=crkve*zlv(j)+cikve*xlv(j)
12345 crkve=crkveuk
12346 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12347 cikve=crkve*zlv(j)+cikve*xlv(j)
12348 crkve=crkveuk
12349 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
12350 &stracks(i)*crkve)
12351 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
12352 &stracks(i)*cikve)
12353 420 continue
12354 goto 470
12355 !--SKEW 18-POLE
12356 430 do 440 j=1,napx
12357 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
12358 &(xv(2,j)-zsiv(1,i))*tilts(i)
12359 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
12360 &(xv(2,j)-zsiv(1,i))*tiltc(i)
12361 crkve=xlv(j)
12362 cikve=zlv(j)
12363 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12364 cikve=crkve*zlv(j)+cikve*xlv(j)
12365 crkve=crkveuk
12366 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12367 cikve=crkve*zlv(j)+cikve*xlv(j)
12368 crkve=crkveuk
12369 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12370 cikve=crkve*zlv(j)+cikve*xlv(j)
12371 crkve=crkveuk
12372 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12373 cikve=crkve*zlv(j)+cikve*xlv(j)
12374 crkve=crkveuk
12375 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12376 cikve=crkve*zlv(j)+cikve*xlv(j)
12377 crkve=crkveuk
12378 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12379 cikve=crkve*zlv(j)+cikve*xlv(j)
12380 crkve=crkveuk
12381 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12382 cikve=crkve*zlv(j)+cikve*xlv(j)
12383 crkve=crkveuk
12384 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
12385 &stracks(i)*crkve)
12386 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
12387 &stracks(i)*cikve)
12388 440 continue
12389 goto 470
12390 !--SKEW 20-POLE
12391 450 do 460 j=1,napx
12392 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
12393 &(xv(2,j)-zsiv(1,i))*tilts(i)
12394 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
12395 &(xv(2,j)-zsiv(1,i))*tiltc(i)
12396 crkve=xlv(j)
12397 cikve=zlv(j)
12398 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12399 cikve=crkve*zlv(j)+cikve*xlv(j)
12400 crkve=crkveuk
12401 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12402 cikve=crkve*zlv(j)+cikve*xlv(j)
12403 crkve=crkveuk
12404 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12405 cikve=crkve*zlv(j)+cikve*xlv(j)
12406 crkve=crkveuk
12407 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12408 cikve=crkve*zlv(j)+cikve*xlv(j)
12409 crkve=crkveuk
12410 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12411 cikve=crkve*zlv(j)+cikve*xlv(j)
12412 crkve=crkveuk
12413 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12414 cikve=crkve*zlv(j)+cikve*xlv(j)
12415 crkve=crkveuk
12416 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12417 cikve=crkve*zlv(j)+cikve*xlv(j)
12418 crkve=crkveuk
12419 crkveuk=crkve*xlv(j)-cikve*zlv(j)
12420 cikve=crkve*zlv(j)+cikve*xlv(j)
12421 crkve=crkveuk
12422 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
12423 &stracks(i)*crkve)
12424 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
12425 &stracks(i)*cikve)
12426 460 continue
12427 goto 470
12428 680 continue
12429 do 690 j=1,napx
12430 if(ibbc.eq.0) then
12431 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
12432 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
12433 else
12434 crkveb(j)= &
12435 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
12436 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
12437 cikveb(j)= &
12438 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
12439 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
12440 endif
12441 rho2b(j)=crkveb(j)*crkveb(j)+cikveb(j)*cikveb(j)
12442 if(rho2b(j).le.pieni) &
12443 &goto 690
12444 tkb(j)=rho2b(j)/(two*sigman2(1,imbb(i)))
12445 if(ibbc.eq.0) then
12446 yv(1,j)=yv(1,j)+oidpsv(j)*(strack(i)*crkveb(j)/rho2b(j)* &
12447 &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))
12448 yv(2,j)=yv(2,j)+oidpsv(j)*(strack(i)*cikveb(j)/rho2b(j)* &
12449 &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))
12450 else
12451 cccc=(strack(i)*crkveb(j)/rho2b(j)* &
12452 &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))*bbcu(imbb(i),11)- &
12453 &(strack(i)*cikveb(j)/rho2b(j)* &
12454 &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
12455 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
12456 cccc=(strack(i)*crkveb(j)/rho2b(j)* &
12457 &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))*bbcu(imbb(i),12)+ &
12458 &(strack(i)*cikveb(j)/rho2b(j)* &
12459 &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
12460 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
12461 endif
12462 690 continue
12463 goto 470
12464 700 continue
12465 if(ibtyp.eq.0) then
12466 do j=1,napx
12467 r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
12468 rb(j)=sqrt(r2b(j))
12469 rkb(j)=strack(i)*pisqrt/rb(j)
12470 if(ibbc.eq.0) then
12471 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
12472 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
12473 else
12474 crkveb(j)= &
12475 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
12476 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
12477 cikveb(j)= &
12478 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
12479 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
12480 endif
12481 xrb(j)=abs(crkveb(j))/rb(j)
12482 zrb(j)=abs(cikveb(j))/rb(j)
12483 call errf(xrb(j),zrb(j),crxb(j),crzb(j))
12484 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
12485 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
12486 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
12487 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
12488 call errf(xbb(j),zbb(j),cbxb(j),cbzb(j))
12489 if(ibbc.eq.0) then
12490 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
12491 &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
12492 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
12493 &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
12494 else
12495 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
12496 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
12497 &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
12498 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
12499 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
12500 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
12501 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
12502 &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
12503 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
12504 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
12505 endif
12506 enddo
12507 else if(ibtyp.eq.1) then
12508 do j=1,napx
12509 r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
12510 rb(j)=sqrt(r2b(j))
12511 rkb(j)=strack(i)*pisqrt/rb(j)
12512 if(ibbc.eq.0) then
12513 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
12514 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
12515 else
12516 crkveb(j)= &
12517 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
12518 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
12519 cikveb(j)= &
12520 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
12521 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
12522 endif
12523 xrb(j)=abs(crkveb(j))/rb(j)
12524 zrb(j)=abs(cikveb(j))/rb(j)
12525 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
12526 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
12527 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
12528 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
12529 enddo
12530 call wzsubv(napx,xrb(1),zrb(1),crxb(1),crzb(1))
12531 call wzsubv(napx,xbb(1),zbb(1),cbxb(1),cbzb(1))
12532 do j=1,napx
12533 if(ibbc.eq.0) then
12534 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
12535 &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
12536 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
12537 &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
12538 else
12539 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
12540 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
12541 &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
12542 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
12543 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
12544 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
12545 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
12546 &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
12547 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
12548 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
12549 endif
12550 enddo
12551 endif
12552 goto 470
12553 720 continue
12554 if(ibtyp.eq.0) then
12555 do j=1,napx
12556 r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
12557 rb(j)=sqrt(r2b(j))
12558 rkb(j)=strack(i)*pisqrt/rb(j)
12559 if(ibbc.eq.0) then
12560 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
12561 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
12562 else
12563 crkveb(j)= &
12564 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
12565 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
12566 cikveb(j)= &
12567 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
12568 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
12569 endif
12570 xrb(j)=abs(crkveb(j))/rb(j)
12571 zrb(j)=abs(cikveb(j))/rb(j)
12572 call errf(zrb(j),xrb(j),crzb(j),crxb(j))
12573 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
12574 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
12575 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
12576 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
12577 call errf(zbb(j),xbb(j),cbzb(j),cbxb(j))
12578 if(ibbc.eq.0) then
12579 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
12580 &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
12581 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
12582 &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
12583 else
12584 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
12585 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
12586 &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
12587 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
12588 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
12589 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
12590 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
12591 &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
12592 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
12593 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
12594 endif
12595 enddo
12596 else if(ibtyp.eq.1) then
12597 do j=1,napx
12598 r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
12599 rb(j)=sqrt(r2b(j))
12600 rkb(j)=strack(i)*pisqrt/rb(j)
12601 if(ibbc.eq.0) then
12602 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
12603 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
12604 else
12605 crkveb(j)= &
12606 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
12607 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
12608 cikveb(j)= &
12609 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
12610 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
12611 endif
12612 xrb(j)=abs(crkveb(j))/rb(j)
12613 zrb(j)=abs(cikveb(j))/rb(j)
12614 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
12615 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
12616 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
12617 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
12618 enddo
12619 call wzsubv(napx,zrb(1),xrb(1),crzb(1),crxb(1))
12620 call wzsubv(napx,zbb(1),xbb(1),cbzb(1),cbxb(1))
12621 do j=1,napx
12622 if(ibbc.eq.0) then
12623 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
12624 &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
12625 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
12626 &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
12627 else
12628 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
12629 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
12630 &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
12631 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
12632 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
12633 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
12634 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
12635 &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
12636 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
12637 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
12638 endif
12639 enddo
12640 endif
12641 goto 470
12642 740 continue
12643 irrtr=imtr(ix)
12644 do j=1,napx
12645 pux=xv(1,j)
12646 dpsv3(j)=dpsv(j)*c1e3
12647 xv(1,j)=cotr(irrtr,1)+rrtr(irrtr,1,1)*pux+ &
12648 &rrtr(irrtr,1,2)*yv(1,j)+idz(1)*dpsv3(j)*rrtr(irrtr,1,6)
12649 yv(1,j)=cotr(irrtr,2)+rrtr(irrtr,2,1)*pux+ &
12650 &rrtr(irrtr,2,2)*yv(1,j)+idz(1)*dpsv3(j)*rrtr(irrtr,2,6)
12651 pux=xv(2,j)
12652 xv(2,j)=cotr(irrtr,3)+rrtr(irrtr,3,3)*pux+ &
12653 &rrtr(irrtr,3,4)*yv(2,j)+idz(2)*dpsv3(j)*rrtr(irrtr,3,6)
12654 yv(2,j)=cotr(irrtr,4)+rrtr(irrtr,4,3)*pux+ &
12655 &rrtr(irrtr,4,4)*yv(2,j)+idz(2)*dpsv3(j)*rrtr(irrtr,4,6)
12656 enddo
12657
12658 !----------------------------------------------------------------------
12659
12660 ! Wire.
12661
12662 goto 470
12663 745 continue
12664 xory=1
12665 nfree=nturn1(ix)
12666 if(n.gt.nfree) then
12667 nac=n-nfree
12668 pi=4d0*atan(1d0)
12669 !---------ACdipAmp input in Tesla*meter converted to KeV/c
12670 !---------ejfv(j) should be in MeV/c --> ACdipAmp/ejfv(j) is in mrad
12671 acdipamp=ed(ix)*clight*1.0d-3
12672 !---------Qd input in tune units
12673 qd=ek(ix)
12674 !---------ACphase input in radians
12675 acphase=acdipph(ix)
12676 nramp1=nturn2(ix)
12677 nplato=nturn3(ix)
12678 nramp2=nturn4(ix)
12679 do j=1,napx
12680 if (xory.eq.1) then
12681 acdipamp2=acdipamp*tilts(i)
12682 acdipamp1=acdipamp*tiltc(i)
12683 else
12684 acdipamp2=acdipamp*tiltc(i)
12685 acdipamp1=-acdipamp*tilts(i)
12686 endif
12687 if(nramp1.gt.nac) then
12688 yv(1,j)=yv(1,j)+acdipamp1* &
12689 &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
12690 yv(2,j)=yv(2,j)+acdipamp2* &
12691 &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
12692 endif
12693 if(nac.ge.nramp1.and.(nramp1+nplato).gt.nac) then
12694 yv(1,j)=yv(1,j)+acdipamp1* &
12695 &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
12696 yv(2,j)=yv(2,j)+acdipamp2* &
12697 &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
12698 endif
12699 if(nac.ge.(nramp1+nplato).and.(nramp2+nramp1+nplato).gt. &
12700 &nac)then
12701 yv(1,j)=yv(1,j)+acdipamp1*sin(2d0*pi*qd*nac+acphase)* &
12702 &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
12703 yv(2,j)=yv(2,j)+acdipamp2*sin(2d0*pi*qd*nac+acphase)* &
12704 &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
12705 endif
12706 enddo
12707 endif
12708 goto 470
12709 746 continue
12710 xory=2
12711 nfree=nturn1(ix)
12712 if(n.gt.nfree) then
12713 nac=n-nfree
12714 pi=4d0*atan(1d0)
12715 !---------ACdipAmp input in Tesla*meter converted to KeV/c
12716 !---------ejfv(j) should be in MeV/c --> ACdipAmp/ejfv(j) is in mrad
12717 acdipamp=ed(ix)*clight*1.0d-3
12718 !---------Qd input in tune units
12719 qd=ek(ix)
12720 !---------ACphase input in radians
12721 acphase=acdipph(ix)
12722 nramp1=nturn2(ix)
12723 nplato=nturn3(ix)
12724 nramp2=nturn4(ix)
12725 do j=1,napx
12726 if (xory.eq.1) then
12727 acdipamp2=acdipamp*tilts(i)
12728 acdipamp1=acdipamp*tiltc(i)
12729 else
12730 acdipamp2=acdipamp*tiltc(i)
12731 acdipamp1=-acdipamp*tilts(i)
12732 endif
12733 if(nramp1.gt.nac) then
12734 yv(1,j)=yv(1,j)+acdipamp1* &
12735 &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
12736 yv(2,j)=yv(2,j)+acdipamp2* &
12737 &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
12738 endif
12739 if(nac.ge.nramp1.and.(nramp1+nplato).gt.nac) then
12740 yv(1,j)=yv(1,j)+acdipamp1* &
12741 &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
12742 yv(2,j)=yv(2,j)+acdipamp2* &
12743 &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
12744 endif
12745 if(nac.ge.(nramp1+nplato).and.(nramp2+nramp1+nplato).gt. &
12746 &nac)then
12747 yv(1,j)=yv(1,j)+acdipamp1*sin(2d0*pi*qd*nac+acphase)* &
12748 &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
12749 yv(2,j)=yv(2,j)+acdipamp2*sin(2d0*pi*qd*nac+acphase)* &
12750 &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
12751 endif
12752 enddo
12753 endif
12754 goto 470
12755
12756 !----------------------------
12757
12758 ! Wire.
12759
12760 748 continue
12761 ! magnetic rigidity
12762 chi = sqrt(e0*e0-pmap*pmap)*c1e6/clight
12763
12764 ix = ixcav
12765 tx = xrms(ix)
12766 ty = zrms(ix)
12767 dx = xpl(ix)
12768 dy = zpl(ix)
12769 embl = ek(ix)
12770 l = wirel(ix)
12771 cur = ed(ix)
12772
12773 leff = embl/cos(tx)/cos(ty)
12774 rx = dx *cos(tx)-embl*sin(tx)/2
12775 lin= dx *sin(tx)+embl*cos(tx)/2
12776 ry = dy *cos(ty)-lin *sin(ty)
12777 lin= lin*cos(ty)+dy *sin(ty)
12778
12779 do 750 j=1, napx
12780
12781 xv(1,j) = xv(1,j) * c1m3
12782 xv(2,j) = xv(2,j) * c1m3
12783 yv(1,j) = yv(1,j) * c1m3
12784 yv(2,j) = yv(2,j) * c1m3
12785
12786 ! print *, 'Start: ',j,xv(1,j),xv(2,j),yv(1,j),
12787 ! &yv(2,j)
12788
12789 ! call drift(-embl/2)
12790
12791 xv(1,j) = xv(1,j) - embl/2*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
12792 &yv(2,j)**2)
12793 xv(2,j) = xv(2,j) - embl/2*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
12794 &yv(2,j)**2)
12795
12796 ! call tilt(tx,ty)
12797
12798 xv(2,j) = xv(2,j)-xv(1,j)*sin(tx)*yv(2,j)/sqrt((1+dpsv(j))**2- &
12799 &yv(2,j)**2)/cos(atan(yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
12800 &yv(2,j)**2))-tx)
12801 xv(1,j) = xv(1,j)*(cos(tx)-sin(tx)*tan(atan(yv(1,j)/ &
12802 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-tx))
12803 yv(1,j) = sqrt((1+dpsv(j))**2-yv(2,j)**2)*sin(atan(yv(1,j)/ &
12804 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-tx)
12805
12806 xv(1,j) = xv(1,j)-xv(2,j)*sin(ty)*yv(1,j)/sqrt((1+dpsv(j))**2- &
12807 &yv(1,j)**2)/cos(atan(yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
12808 &yv(2,j)**2))-ty)
12809 xv(2,j) = xv(2,j)*(cos(ty)-sin(ty)*tan(atan(yv(2,j)/ &
12810 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-ty))
12811 yv(2,j) = sqrt((1+dpsv(j))**2-yv(1,j)**2)*sin(atan(yv(2,j)/ &
12812 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-ty)
12813
12814 ! call drift(lin)
12815
12816 xv(1,j) = xv(1,j) + lin*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
12817 &yv(2,j)**2)
12818 xv(2,j) = xv(2,j) + lin*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
12819 &yv(2,j)**2)
12820
12821 ! call kick(l,cur,lin,rx,ry,chi)
12822
12823 xi = xv(1,j)-rx
12824 yi = xv(2,j)-ry
12825 yv(1,j) = yv(1,j)-1.0d-7*cur/chi*xi/(xi**2+yi**2)* &
12826 &(sqrt((lin+l)**2+xi**2+yi**2)-sqrt((lin-l)**2+ &
12827 &xi**2+yi**2))
12828 !GRD FOR CONSISTENSY
12829 ! yv(2,j) = yv(2,j)-1e-7*cur/chi*yi/(xi**2+yi**2)* &
12830 yv(2,j) = yv(2,j)-1.0d-7*cur/chi*yi/(xi**2+yi**2)* &
12831 &(sqrt((lin+l)**2+xi**2+yi**2)-sqrt((lin-l)**2+ &
12832 &xi**2+yi**2))
12833
12834 ! call drift(leff-lin)
12835
12836 xv(1,j) = xv(1,j) + (leff-lin)*yv(1,j)/sqrt((1+dpsv(j))**2- &
12837 &yv(1,j)**2-yv(2,j)**2)
12838 xv(2,j) = xv(2,j) + (leff-lin)*yv(2,j)/sqrt((1+dpsv(j))**2- &
12839 &yv(1,j)**2-yv(2,j)**2)
12840
12841 ! call invtilt(tx,ty)
12842
12843 xv(1,j) = xv(1,j)-xv(2,j)*sin(-ty)*yv(1,j)/sqrt((1+dpsv(j))**2- &
12844 &yv(1,j)**2)/cos(atan(yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
12845 &yv(2,j)**2))+ty)
12846 xv(2,j) = xv(2,j)*(cos(-ty)-sin(-ty)*tan(atan(yv(2,j)/ &
12847 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+ty))
12848 yv(2,j) = sqrt((1+dpsv(j))**2-yv(1,j)**2)*sin(atan(yv(2,j)/ &
12849 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+ty)
12850
12851 xv(2,j) = xv(2,j)-xv(1,j)*sin(-tx)*yv(2,j)/sqrt((1+dpsv(j))**2- &
12852 &yv(2,j)**2)/cos(atan(yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
12853 &yv(2,j)**2))+tx)
12854 xv(1,j) = xv(1,j)*(cos(-tx)-sin(-tx)*tan(atan(yv(1,j)/ &
12855 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+tx))
12856 yv(1,j) = sqrt((1+dpsv(j))**2-yv(2,j)**2)*sin(atan(yv(1,j)/ &
12857 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+tx)
12858
12859 ! call shift(-embl*tan(tx),-embl*tan(ty)/cos(tx))
12860
12861 xv(1,j) = xv(1,j) + embl*tan(tx)
12862 xv(2,j) = xv(2,j) + embl*tan(ty)/cos(tx)
12863
12864 ! call drift(-embl/2)
12865
12866 xv(1,j) = xv(1,j) - embl/2*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
12867 &yv(2,j)**2)
12868 xv(2,j) = xv(2,j) - embl/2*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
12869 &yv(2,j)**2)
12870
12871 xv(1,j) = xv(1,j) * c1e3
12872 xv(2,j) = xv(2,j) * c1e3
12873 yv(1,j) = yv(1,j) * c1e3
12874 yv(2,j) = yv(2,j) * c1e3
12875
12876 ! print *, 'End: ',j,xv(1,j),xv(2,j),yv(1,j),
12877 ! &yv(2,j)
12878
12879 !-----------------------------------------------------------------------
12880
12881 750 continue
12882 goto 470
12883
12884 !----------------------------
12885
12886 470 continue
12887 llost=.false.
12888 do j=1,napx
12889 llost=llost.or. &
12890 &abs(xv(1,j)).gt.aper(1).or.abs(xv(2,j)).gt.aper(2)
12891 enddo
12892 if (llost) then
12893 kpz=abs(kp(ix))
12894 if(kpz.eq.2) then
12895 call lostpar3(i,ix,nthinerr)
12896 if(nthinerr.ne.0) return
12897 elseif(kpz.eq.3) then
12898 call lostpar4(i,ix,nthinerr)
12899 if(nthinerr.ne.0) return
12900 else
12901 call lostpar2(i,ix,nthinerr)
12902 if(nthinerr.ne.0) return
12903 endif
12904 endif
12905 480 continue
12906 call lostpart(nthinerr)
12907 if(nthinerr.ne.0) return
12908 if(ntwin.ne.2) call dist1
12909 if(mod(n,nwr(4)).eq.0) call write6(n)
12910 490 continue
12911 return
12912 end
12913 subroutine thck6d(nthinerr)
12914 !-----------------------------------------------------------------------
12915 !
12916 ! TRACK THICK LENS 6D
12917 !
12918 !
12919 ! F. SCHMIDT
12920 !-----------------------------------------------------------------------
12921 implicit none
12922 integer i,idz1,idz2,irrtr,ix,j,jb,jmel,jx,k,kpz,n,nmz,nthinerr
12923 double precision cbxb,cbzb,cccc,cikve,cikveb,crkve,crkveb,crkveuk,&
12924 &crxb,crzb,dpsv3,pux,puxve1,puxve2,puzve1,puzve2,r0,r2b,rb,rho2b, &
12925 &rkb,tkb,xbb,xlvj,xrb,yv1j,yv2j,zbb,zlvj,zrb
12926 integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1, &
12927 &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran, &
12928 &nrco,ntr,nzfz
12929 parameter(npart = 64,nmac = 1)
12930 parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000, &
12931 &nzfz = 300000,mmul = 11)
12932 parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5, &
12933 &nema = 15)
12934 parameter(mcor = 10,mcop = mcor+6, mbea = 15)
12935 parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
12936 parameter(nmon1 = 600,ncor1 = 600)
12937 parameter(ntr = 20,nbb = 160)
12938 integer ireturn, xory, nac, nfree, nramp1,nplato, nramp2
12939 double precision e0fo,e0o,xv1j,xv2j
12940 double precision acdipamp, qd, acphase,acdipamp2, &
12941 &acdipamp1
12942 double precision l,cur,dx,dy,tx,ty,embl,leff,rx,ry,lin,chi,xi,yi
12943 logical llost
12944 double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3, &
12945 &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21, &
12946 &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
12947 &one,pieni,pmae,pmap,three,two,zero
12948 parameter(pieni = 1d-38)
12949 parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
12950 parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
12951 parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
12952 parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
12953 parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 = &
12954 &1.0d16)
12955 parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
12956 parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
12957 parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
12958 parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
12959 parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
12960 parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
12961 parameter(pmap = 938.271998d0,pmae = .510998902d0)
12962 parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
12963 integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo, &
12964 &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor, &
12965 &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb, &
12966 &imc,imtr,iorg,iout, &
12967 &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires, &
12968 &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw, &
12969 &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox, &
12970 &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo, &
12971 &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx, &
12972 &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr, &
12973 &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew, &
12974 &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr, &
12975 &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
12976 double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu, &
12977 &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
12978 &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft, &
12979 &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
12980 &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign, &
12981 &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum, &
12982 &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
12983 &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph, &
12984 &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
12985 &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel, &
12986 &acdipph
12987 real hmal
12988 character*16 bez,bezb,bezr,erbez,bezl
12989 character*80 toptit,sixtit,commen
12990 common/erro/ierro,erbez
12991 common/kons/pi,pi2,pisqrt,rad
12992 common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
12993 common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
12994 common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
12995 common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
12996 common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
12997 common/syos2/rvf(mpa)
12998 common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
12999 &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
13000 common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3), &
13001 &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen, &
13002 &iicav,itionc(nele),ition,idp,ncy,ixcav
13003 common/corcom/dpscor,sigcor,icode,idam,its6d
13004 common/multi/bk0(nele,mmul),ak0(nele,mmul), &
13005 &bka(nele,mmul),aka(nele,mmul)
13006 common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
13007 common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
13008 common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz), &
13009 &tilts(nblz),mout2,icext(nblz),icextal(nblz)
13010 common/beo /aper(2),di0(2),dip0(2),ta(6,6)
13011 common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
13012 &iout
13013 common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
13014 common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint, &
13015 &ntco,eui,euii,nlin,bezl(nele)
13016 common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2), &
13017 &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr, &
13018 &ncororb(nele)
13019 common/apert/apx(nele),apz(nele),ape(3,nele)
13020 common/clos/sigma0(2),iclo,ncorru,ncorrep
13021 common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20), &
13022 &ratioe(nele),iratioe(nele),icoe
13023 common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
13024 common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
13025 common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
13026 common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
13027 common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2, &
13028 &nstart,nstop,iskip,iconv,imad
13029 common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
13030 common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
13031 common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
13032 common/ripp2/nrturn
13033 common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
13034 common/pawc/hmal(nplo)
13035 common/tit/sixtit,commen,ithick
13036 common/co6d/clo6(3),clop6(3)
13037 common/dkic/dki(nele,3)
13038 common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb), &
13039 &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart), &
13040 &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar, &
13041 &nbeam,ibbc,ibeco,ibtyp,lhc
13042 common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
13043 common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
13044 common/wireco/ wirel(nele)
13045 common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele), &
13046 &nturn3(nele), nturn4(nele)
13047 integer idz,itra
13048 double precision al,as,chi0,chid,dp1,dps,exz,sigm
13049 common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa), &
13050 &dps(mpa),idz(2)
13051 common/anf/chi0,chid,exz(2,6),dp1,itra
13052 integer ichrom,is
13053 double precision alf0,amp,bet0,clo,clop,cro,x,y
13054 common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
13055 common/chrom/cro(2),is(2),ichrom
13056 integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
13057 &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
13058 double precision dpmax,preda,weig1,weig2
13059 character*16 coel
13060 common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
13061 common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
13062 common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
13063 &coel(10)
13064 double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
13065 &zsi
13066 real tlim,time0,time1
13067 common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz), &
13068 &aai(nblz,mmul),bbi(nblz,mmul)
13069 common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
13070 common/damp/damp,ampt
13071 common/ttime/tlim,time0,time1
13072 double precision tasm
13073 common/tasm/tasm(6,6)
13074 integer iv,ixv,nlostp,nms,numxv
13075 double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
13076 &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
13077 &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl, &
13078 &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
13079 &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv, &
13080 &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas, &
13081 &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
13082 &zsiv,zsv
13083 logical pstop
13084 common/main1/ &
13085 &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz), &
13086 &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz), &
13087 &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2), &
13088 &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart), &
13089 &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart), &
13090 &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart), &
13091 &xlv(npart),zlv(npart),pstop(npart),rvv(npart), &
13092 &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
13093 common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart), &
13094 &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart), &
13095 &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart), &
13096 &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart), &
13097 &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart), &
13098 &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
13099 &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
13100 &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart), &
13101 &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
13102 common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo), &
13103 &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart), &
13104 &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6), &
13105 &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
13106 integer numx
13107 double precision e0f
13108 common/main4/ e0f,numx
13109 integer ktrack,nwri
13110 double precision dpsv1,strack,strackc,stracks
13111 common/track/ ktrack(nblz),strack(nblz),strackc(nblz), &
13112 &stracks(nblz),dpsv1(npart),nwri
13113 double precision cc,xlim,ylim
13114 parameter(cc = 1.12837916709551d0)
13115 parameter(xlim = 5.33d0)
13116 parameter(ylim = 4.29d0)
13117 dimension crkveb(npart),cikveb(npart),rho2b(npart),tkb(npart), &
13118 &r2b(npart),rb(npart),rkb(npart), &
13119 &xrb(npart),zrb(npart),xbb(npart),zbb(npart),crxb(npart), &
13120 &crzb(npart),cbxb(npart),cbzb(npart)
13121 dimension dpsv3(npart)
13122 save
13123 !-----------------------------------------------------------------------
13124 nthinerr=0
13125 idz1=idz(1)
13126 idz2=idz(2)
13127 do 510 n=1,numl
13128 numx=n-1
13129 if(irip.eq.1) call ripple(n)
13130 if(mod(numx,nwri).eq.0) call writebin(nthinerr)
13131 if(nthinerr.ne.0) return
13132 do 500 i=1,iu
13133 if(ktrack(i).eq.1) then
13134 ix=ic(i)
13135 else
13136 ix=ic(i)-nblo
13137 endif
13138 !----------count 44
13139 goto(20,40,740,500,500,500,500,500,500,500,60,80,100,120, &
13140 &140,160,180,200,220,240,290,310,330,350,370,390,410,430, &
13141 &450,470,490,260,520,540,560,580,600,620,640,660,680,700,720 &
13142 &,730,748,500,500,500,500,500,745,746),ktrack(i)
13143 goto 500
13144 20 jmel=mel(ix)
13145 do 30 jb=1,jmel
13146 jx=mtyp(ix,jb)
13147 do 30 j=1,napx
13148 puxve1=xv(1,j)
13149 puzve1=yv(1,j)
13150 puxve2=xv(2,j)
13151 puzve2=yv(2,j)
13152 sigmv(j)=sigmv(j)+as(1,1,j,jx)+puxve1*(as(2,1,j,jx)+ as &
13153 &(4,1,j,jx)*puzve1+as(5,1,j,jx)*puxve1)+ puzve1*(as &
13154 &(3,1,j,jx)+as(6,1,j,jx)*puzve1) &
13155 &+as(1,2,j,jx)+puxve2*(as(2,2,j,jx)+ as &
13156 &(4,2,j,jx)*puzve2+as(5,2,j,jx)*puxve2)+ puzve2*(as &
13157 &(3,2,j,jx)+as(6,2,j,jx)*puzve2)
13158 xv(1,j)=al(1,1,j,jx)*puxve1+ al(2,1,j,jx)*puzve1+idz1*al&
13159 &(5,1,j,jx)
13160 xv(2,j)=al(1,2,j,jx)*puxve2+ al(2,2,j,jx)*puzve2+idz2*al&
13161 &(5,2,j,jx)
13162 yv(1,j)=al(3,1,j,jx)*puxve1+ al(4,1,j,jx)*puzve1+idz1*al&
13163 &(6,1,j,jx)
13164 yv(2,j)=al(3,2,j,jx)*puxve2+ al(4,2,j,jx)*puzve2+idz2*al&
13165 &(6,2,j,jx)
13166 30 continue
13167 goto 500
13168 40 do 50 j=1,napx
13169 ejf0v(j)=ejfv(j)
13170 if(abs(dppoff).gt.pieni) sigmv(j)=sigmv(j)-sigmoff(i)
13171 if(kz(ix).eq.12) then
13172 ejv(j)=ejv(j)+ed(ix)*sin(hsyc(ix)*sigmv(j)+ &
13173 &phasc(ix))
13174 else
13175 ejv(j)=ejv(j)+hsy(1)*sin(hsy(3)*sigmv(j))
13176 endif
13177 ejfv(j)=sqrt(ejv(j)*ejv(j)-pma*pma)
13178 rvv(j)=(ejv(j)*e0f)/(e0*ejfv(j))
13179 dpsv(j)=(ejfv(j)-e0f)/e0f
13180 oidpsv(j)=one/(one+dpsv(j))
13181 dpsv1(j)=dpsv(j)*c1e3*oidpsv(j)
13182 yv(1,j)=ejf0v(j)/ejfv(j)*yv(1,j)
13183 50 yv(2,j)=ejf0v(j)/ejfv(j)*yv(2,j)
13184 if(n.eq.1) write(98,'(1p,6(2x,e25.18))') &
13185 &(xv(1,j),yv(1,j),xv(2,j),yv(2,j),sigmv(j),dpsv(j), &
13186 &j=1,napx)
13187 call synuthck
13188 goto 490
13189 !--HORIZONTAL DIPOLE
13190 60 do 70 j=1,napx
13191 yv(1,j)=yv(1,j)+strackc(i)*oidpsv(j)
13192 yv(2,j)=yv(2,j)+stracks(i)*oidpsv(j)
13193 70 continue
13194 goto 490
13195 !--NORMAL QUADRUPOLE
13196 80 do 90 j=1,napx
13197 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13198 &(xv(2,j)-zsiv(1,i))*tilts(i)
13199 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13200 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13201 crkve=xlv(j)
13202 cikve=zlv(j)
13203 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
13204 &stracks(i)*cikve)
13205 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
13206 &stracks(i)*crkve)
13207 90 continue
13208 goto 490
13209 !--NORMAL SEXTUPOLE
13210 100 do 110 j=1,napx
13211 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13212 &(xv(2,j)-zsiv(1,i))*tilts(i)
13213 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13214 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13215 crkve=xlv(j)
13216 cikve=zlv(j)
13217 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13218 cikve=crkve*zlv(j)+cikve*xlv(j)
13219 crkve=crkveuk
13220 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
13221 &stracks(i)*cikve)
13222 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
13223 &stracks(i)*crkve)
13224 110 continue
13225 goto 490
13226 !--NORMAL OCTUPOLE
13227 120 do 130 j=1,napx
13228 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13229 &(xv(2,j)-zsiv(1,i))*tilts(i)
13230 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13231 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13232 crkve=xlv(j)
13233 cikve=zlv(j)
13234 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13235 cikve=crkve*zlv(j)+cikve*xlv(j)
13236 crkve=crkveuk
13237 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13238 cikve=crkve*zlv(j)+cikve*xlv(j)
13239 crkve=crkveuk
13240 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
13241 &stracks(i)*cikve)
13242 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
13243 &stracks(i)*crkve)
13244 130 continue
13245 goto 490
13246 !--NORMAL DECAPOLE
13247 140 do 150 j=1,napx
13248 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13249 &(xv(2,j)-zsiv(1,i))*tilts(i)
13250 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13251 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13252 crkve=xlv(j)
13253 cikve=zlv(j)
13254 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13255 cikve=crkve*zlv(j)+cikve*xlv(j)
13256 crkve=crkveuk
13257 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13258 cikve=crkve*zlv(j)+cikve*xlv(j)
13259 crkve=crkveuk
13260 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13261 cikve=crkve*zlv(j)+cikve*xlv(j)
13262 crkve=crkveuk
13263 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
13264 &stracks(i)*cikve)
13265 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
13266 &stracks(i)*crkve)
13267 150 continue
13268 goto 490
13269 !--NORMAL DODECAPOLE
13270 160 do 170 j=1,napx
13271 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13272 &(xv(2,j)-zsiv(1,i))*tilts(i)
13273 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13274 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13275 crkve=xlv(j)
13276 cikve=zlv(j)
13277 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13278 cikve=crkve*zlv(j)+cikve*xlv(j)
13279 crkve=crkveuk
13280 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13281 cikve=crkve*zlv(j)+cikve*xlv(j)
13282 crkve=crkveuk
13283 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13284 cikve=crkve*zlv(j)+cikve*xlv(j)
13285 crkve=crkveuk
13286 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13287 cikve=crkve*zlv(j)+cikve*xlv(j)
13288 crkve=crkveuk
13289 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
13290 &stracks(i)*cikve)
13291 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
13292 &stracks(i)*crkve)
13293 170 continue
13294 goto 490
13295 !--NORMAL 14-POLE
13296 180 do 190 j=1,napx
13297 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13298 &(xv(2,j)-zsiv(1,i))*tilts(i)
13299 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13300 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13301 crkve=xlv(j)
13302 cikve=zlv(j)
13303 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13304 cikve=crkve*zlv(j)+cikve*xlv(j)
13305 crkve=crkveuk
13306 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13307 cikve=crkve*zlv(j)+cikve*xlv(j)
13308 crkve=crkveuk
13309 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13310 cikve=crkve*zlv(j)+cikve*xlv(j)
13311 crkve=crkveuk
13312 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13313 cikve=crkve*zlv(j)+cikve*xlv(j)
13314 crkve=crkveuk
13315 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13316 cikve=crkve*zlv(j)+cikve*xlv(j)
13317 crkve=crkveuk
13318 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
13319 &stracks(i)*cikve)
13320 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
13321 &stracks(i)*crkve)
13322 190 continue
13323 goto 490
13324 !--NORMAL 16-POLE
13325 200 do 210 j=1,napx
13326 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13327 &(xv(2,j)-zsiv(1,i))*tilts(i)
13328 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13329 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13330 crkve=xlv(j)
13331 cikve=zlv(j)
13332 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13333 cikve=crkve*zlv(j)+cikve*xlv(j)
13334 crkve=crkveuk
13335 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13336 cikve=crkve*zlv(j)+cikve*xlv(j)
13337 crkve=crkveuk
13338 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13339 cikve=crkve*zlv(j)+cikve*xlv(j)
13340 crkve=crkveuk
13341 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13342 cikve=crkve*zlv(j)+cikve*xlv(j)
13343 crkve=crkveuk
13344 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13345 cikve=crkve*zlv(j)+cikve*xlv(j)
13346 crkve=crkveuk
13347 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13348 cikve=crkve*zlv(j)+cikve*xlv(j)
13349 crkve=crkveuk
13350 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
13351 &stracks(i)*cikve)
13352 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
13353 &stracks(i)*crkve)
13354 210 continue
13355 goto 490
13356 !--NORMAL 18-POLE
13357 220 do 230 j=1,napx
13358 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13359 &(xv(2,j)-zsiv(1,i))*tilts(i)
13360 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13361 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13362 crkve=xlv(j)
13363 cikve=zlv(j)
13364 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13365 cikve=crkve*zlv(j)+cikve*xlv(j)
13366 crkve=crkveuk
13367 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13368 cikve=crkve*zlv(j)+cikve*xlv(j)
13369 crkve=crkveuk
13370 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13371 cikve=crkve*zlv(j)+cikve*xlv(j)
13372 crkve=crkveuk
13373 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13374 cikve=crkve*zlv(j)+cikve*xlv(j)
13375 crkve=crkveuk
13376 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13377 cikve=crkve*zlv(j)+cikve*xlv(j)
13378 crkve=crkveuk
13379 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13380 cikve=crkve*zlv(j)+cikve*xlv(j)
13381 crkve=crkveuk
13382 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13383 cikve=crkve*zlv(j)+cikve*xlv(j)
13384 crkve=crkveuk
13385 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
13386 &stracks(i)*cikve)
13387 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
13388 &stracks(i)*crkve)
13389 230 continue
13390 goto 490
13391 !--NORMAL 20-POLE
13392 240 do 250 j=1,napx
13393 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13394 &(xv(2,j)-zsiv(1,i))*tilts(i)
13395 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13396 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13397 crkve=xlv(j)
13398 cikve=zlv(j)
13399 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13400 cikve=crkve*zlv(j)+cikve*xlv(j)
13401 crkve=crkveuk
13402 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13403 cikve=crkve*zlv(j)+cikve*xlv(j)
13404 crkve=crkveuk
13405 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13406 cikve=crkve*zlv(j)+cikve*xlv(j)
13407 crkve=crkveuk
13408 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13409 cikve=crkve*zlv(j)+cikve*xlv(j)
13410 crkve=crkveuk
13411 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13412 cikve=crkve*zlv(j)+cikve*xlv(j)
13413 crkve=crkveuk
13414 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13415 cikve=crkve*zlv(j)+cikve*xlv(j)
13416 crkve=crkveuk
13417 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13418 cikve=crkve*zlv(j)+cikve*xlv(j)
13419 crkve=crkveuk
13420 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13421 cikve=crkve*zlv(j)+cikve*xlv(j)
13422 crkve=crkveuk
13423 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
13424 &stracks(i)*cikve)
13425 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
13426 &stracks(i)*crkve)
13427 250 continue
13428 goto 490
13429 520 continue
13430 do 530 j=1,napx
13431 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13432 &(xv(2,j)-zsiv(1,i))*tilts(i)
13433 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13434 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13435 yv(1,j)=yv(1,j)-(strack(i)*xlvj*oidpsv(j) &
13436 &+dpsv1(j))*dki(ix,1)*tiltc(i) &
13437 &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
13438 yv(2,j)=yv(2,j)-(strack(i)*xlvj*oidpsv(j) &
13439 &+dpsv1(j))*dki(ix,1)*tilts(i) &
13440 &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
13441 sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
13442 530 continue
13443 goto 490
13444 540 continue
13445 do 550 j=1,napx
13446 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13447 &(xv(2,j)-zsiv(1,i))*tilts(i)
13448 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13449 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13450 yv(1,j)=yv(1,j)-(strack(i)*xlvj*oidpsv(j) &
13451 &+dpsv1(j))*dki(ix,1)*tiltc(i) &
13452 &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
13453 yv(2,j)=yv(2,j)-(strack(i)*xlvj*oidpsv(j) &
13454 &+dpsv1(j))*dki(ix,1)*tilts(i) &
13455 &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
13456 sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
13457 550 continue
13458 goto 260
13459 560 continue
13460 do 570 j=1,napx
13461 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13462 &(xv(2,j)-zsiv(1,i))*tilts(i)
13463 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13464 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13465 yv(1,j)=yv(1,j)-strackc(i)*dpsv1(j) &
13466 &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
13467 yv(2,j)=yv(2,j)-stracks(i)*dpsv1(j) &
13468 &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
13469 sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
13470 570 continue
13471 goto 490
13472 580 continue
13473 do 590 j=1,napx
13474 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13475 &(xv(2,j)-zsiv(1,i))*tilts(i)
13476 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13477 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13478 yv(1,j)=yv(1,j)-strackc(i)*dpsv1(j) &
13479 &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
13480 yv(2,j)=yv(2,j)-stracks(i)*dpsv1(j) &
13481 &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
13482 sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
13483 590 continue
13484 goto 260
13485 600 continue
13486 do 610 j=1,napx
13487 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13488 &(xv(2,j)-zsiv(1,i))*tilts(i)
13489 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13490 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13491 yv(1,j)=yv(1,j)+(strack(i)*zlvj*oidpsv(j) &
13492 &-dpsv1(j))*dki(ix,2)*tilts(i) &
13493 &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
13494 yv(2,j)=yv(2,j)-(strack(i)*zlvj*oidpsv(j) &
13495 &-dpsv1(j))*dki(ix,2)*tiltc(i) &
13496 &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
13497 sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
13498 610 continue
13499 goto 490
13500 620 continue
13501 do 630 j=1,napx
13502 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13503 &(xv(2,j)-zsiv(1,i))*tilts(i)
13504 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13505 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13506 yv(1,j)=yv(1,j)+(strack(i)*zlvj*oidpsv(j) &
13507 &-dpsv1(j))*dki(ix,2)*tilts(i) &
13508 &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
13509 yv(2,j)=yv(2,j)-(strack(i)*zlvj*oidpsv(j) &
13510 &-dpsv1(j))*dki(ix,2)*tiltc(i) &
13511 &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
13512 sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
13513 630 continue
13514 goto 260
13515 640 continue
13516 do 650 j=1,napx
13517 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13518 &(xv(2,j)-zsiv(1,i))*tilts(i)
13519 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13520 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13521 yv(1,j)=yv(1,j)-stracks(i)*dpsv1(j) &
13522 &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
13523 yv(2,j)=yv(2,j)+strackc(i)*dpsv1(j) &
13524 &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
13525 sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
13526 650 continue
13527 goto 490
13528 660 continue
13529 do 670 j=1,napx
13530 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13531 &(xv(2,j)-zsiv(1,i))*tilts(i)
13532 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13533 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13534 yv(1,j)=yv(1,j)-stracks(i)*dpsv1(j) &
13535 &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
13536 yv(2,j)=yv(2,j)+strackc(i)*dpsv1(j) &
13537 &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
13538 sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
13539 670 continue
13540 260 r0=ek(ix)
13541 nmz=nmu(ix)
13542 if(nmz.ge.2) then
13543 do 280 j=1,napx
13544 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13545 &(xv(2,j)-zsiv(1,i))*tilts(i)
13546 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13547 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13548 yv1j=bbiv(1,1,i)+bbiv(2,1,i)*xlvj+aaiv(2,1,i)*zlvj
13549 yv2j=aaiv(1,1,i)-bbiv(2,1,i)*zlvj+aaiv(2,1,i)*xlvj
13550 crkve=xlvj
13551 cikve=zlvj
13552 do 270 k=3,nmz
13553 crkveuk=crkve*xlvj-cikve*zlvj
13554 cikve=crkve*zlvj+cikve*xlvj
13555 crkve=crkveuk
13556 yv1j=yv1j+bbiv(k,1,i)*crkve+aaiv(k,1,i)*cikve
13557 yv2j=yv2j-bbiv(k,1,i)*cikve+aaiv(k,1,i)*crkve
13558 270 continue
13559 yv(1,j)=yv(1,j)+(tiltc(i)*yv1j-tilts(i)*yv2j)*oidpsv(j)
13560 yv(2,j)=yv(2,j)+(tiltc(i)*yv2j+tilts(i)*yv1j)*oidpsv(j)
13561 280 continue
13562 else
13563 do 275 j=1,napx
13564 yv(1,j)=yv(1,j)+(tiltc(i)*bbiv(1,1,i)- &
13565 &tilts(i)*aaiv(1,1,i))*oidpsv(j)
13566 yv(2,j)=yv(2,j)+(tiltc(i)*aaiv(1,1,i)+ &
13567 &tilts(i)*bbiv(1,1,i))*oidpsv(j)
13568 275 continue
13569 endif
13570 goto 490
13571 !--SKEW ELEMENTS
13572 !--VERTICAL DIPOLE
13573 290 do 300 j=1,napx
13574 yv(1,j)=yv(1,j)-stracks(i)*oidpsv(j)
13575 yv(2,j)=yv(2,j)+strackc(i)*oidpsv(j)
13576 300 continue
13577 goto 490
13578 !--SKEW QUADRUPOLE
13579 310 do 320 j=1,napx
13580 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13581 &(xv(2,j)-zsiv(1,i))*tilts(i)
13582 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13583 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13584 crkve=xlv(j)
13585 cikve=zlv(j)
13586 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
13587 &stracks(i)*crkve)
13588 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
13589 &stracks(i)*cikve)
13590 320 continue
13591 goto 490
13592 !--SKEW SEXTUPOLE
13593 330 do 340 j=1,napx
13594 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13595 &(xv(2,j)-zsiv(1,i))*tilts(i)
13596 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13597 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13598 crkve=xlv(j)
13599 cikve=zlv(j)
13600 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13601 cikve=crkve*zlv(j)+cikve*xlv(j)
13602 crkve=crkveuk
13603 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
13604 &stracks(i)*crkve)
13605 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
13606 &stracks(i)*cikve)
13607 340 continue
13608 goto 490
13609 !--SKEW OCTUPOLE
13610 350 do 360 j=1,napx
13611 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13612 &(xv(2,j)-zsiv(1,i))*tilts(i)
13613 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13614 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13615 crkve=xlv(j)
13616 cikve=zlv(j)
13617 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13618 cikve=crkve*zlv(j)+cikve*xlv(j)
13619 crkve=crkveuk
13620 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13621 cikve=crkve*zlv(j)+cikve*xlv(j)
13622 crkve=crkveuk
13623 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
13624 &stracks(i)*crkve)
13625 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
13626 &stracks(i)*cikve)
13627 360 continue
13628 goto 490
13629 !--SKEW DECAPOLE
13630 370 do 380 j=1,napx
13631 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13632 &(xv(2,j)-zsiv(1,i))*tilts(i)
13633 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13634 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13635 crkve=xlv(j)
13636 cikve=zlv(j)
13637 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13638 cikve=crkve*zlv(j)+cikve*xlv(j)
13639 crkve=crkveuk
13640 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13641 cikve=crkve*zlv(j)+cikve*xlv(j)
13642 crkve=crkveuk
13643 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13644 cikve=crkve*zlv(j)+cikve*xlv(j)
13645 crkve=crkveuk
13646 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
13647 &stracks(i)*crkve)
13648 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
13649 &stracks(i)*cikve)
13650 380 continue
13651 goto 490
13652 !--SKEW DODECAPOLE
13653 390 do 400 j=1,napx
13654 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13655 &(xv(2,j)-zsiv(1,i))*tilts(i)
13656 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13657 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13658 crkve=xlv(j)
13659 cikve=zlv(j)
13660 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13661 cikve=crkve*zlv(j)+cikve*xlv(j)
13662 crkve=crkveuk
13663 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13664 cikve=crkve*zlv(j)+cikve*xlv(j)
13665 crkve=crkveuk
13666 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13667 cikve=crkve*zlv(j)+cikve*xlv(j)
13668 crkve=crkveuk
13669 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13670 cikve=crkve*zlv(j)+cikve*xlv(j)
13671 crkve=crkveuk
13672 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
13673 &stracks(i)*crkve)
13674 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
13675 &stracks(i)*cikve)
13676 400 continue
13677 goto 490
13678 !--SKEW 14-POLE
13679 410 do 420 j=1,napx
13680 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13681 &(xv(2,j)-zsiv(1,i))*tilts(i)
13682 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13683 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13684 crkve=xlv(j)
13685 cikve=zlv(j)
13686 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13687 cikve=crkve*zlv(j)+cikve*xlv(j)
13688 crkve=crkveuk
13689 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13690 cikve=crkve*zlv(j)+cikve*xlv(j)
13691 crkve=crkveuk
13692 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13693 cikve=crkve*zlv(j)+cikve*xlv(j)
13694 crkve=crkveuk
13695 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13696 cikve=crkve*zlv(j)+cikve*xlv(j)
13697 crkve=crkveuk
13698 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13699 cikve=crkve*zlv(j)+cikve*xlv(j)
13700 crkve=crkveuk
13701 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
13702 &stracks(i)*crkve)
13703 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
13704 &stracks(i)*cikve)
13705 420 continue
13706 goto 490
13707 !--SKEW 16-POLE
13708 430 do 440 j=1,napx
13709 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13710 &(xv(2,j)-zsiv(1,i))*tilts(i)
13711 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13712 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13713 crkve=xlv(j)
13714 cikve=zlv(j)
13715 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13716 cikve=crkve*zlv(j)+cikve*xlv(j)
13717 crkve=crkveuk
13718 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13719 cikve=crkve*zlv(j)+cikve*xlv(j)
13720 crkve=crkveuk
13721 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13722 cikve=crkve*zlv(j)+cikve*xlv(j)
13723 crkve=crkveuk
13724 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13725 cikve=crkve*zlv(j)+cikve*xlv(j)
13726 crkve=crkveuk
13727 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13728 cikve=crkve*zlv(j)+cikve*xlv(j)
13729 crkve=crkveuk
13730 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13731 cikve=crkve*zlv(j)+cikve*xlv(j)
13732 crkve=crkveuk
13733 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
13734 &stracks(i)*crkve)
13735 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
13736 &stracks(i)*cikve)
13737 440 continue
13738 goto 490
13739 !--SKEW 18-POLE
13740 450 do 460 j=1,napx
13741 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13742 &(xv(2,j)-zsiv(1,i))*tilts(i)
13743 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13744 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13745 crkve=xlv(j)
13746 cikve=zlv(j)
13747 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13748 cikve=crkve*zlv(j)+cikve*xlv(j)
13749 crkve=crkveuk
13750 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13751 cikve=crkve*zlv(j)+cikve*xlv(j)
13752 crkve=crkveuk
13753 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13754 cikve=crkve*zlv(j)+cikve*xlv(j)
13755 crkve=crkveuk
13756 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13757 cikve=crkve*zlv(j)+cikve*xlv(j)
13758 crkve=crkveuk
13759 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13760 cikve=crkve*zlv(j)+cikve*xlv(j)
13761 crkve=crkveuk
13762 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13763 cikve=crkve*zlv(j)+cikve*xlv(j)
13764 crkve=crkveuk
13765 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13766 cikve=crkve*zlv(j)+cikve*xlv(j)
13767 crkve=crkveuk
13768 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
13769 &stracks(i)*crkve)
13770 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
13771 &stracks(i)*cikve)
13772 460 continue
13773 goto 490
13774 !--SKEW 20-POLE
13775 470 do 480 j=1,napx
13776 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
13777 &(xv(2,j)-zsiv(1,i))*tilts(i)
13778 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
13779 &(xv(2,j)-zsiv(1,i))*tiltc(i)
13780 crkve=xlv(j)
13781 cikve=zlv(j)
13782 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13783 cikve=crkve*zlv(j)+cikve*xlv(j)
13784 crkve=crkveuk
13785 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13786 cikve=crkve*zlv(j)+cikve*xlv(j)
13787 crkve=crkveuk
13788 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13789 cikve=crkve*zlv(j)+cikve*xlv(j)
13790 crkve=crkveuk
13791 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13792 cikve=crkve*zlv(j)+cikve*xlv(j)
13793 crkve=crkveuk
13794 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13795 cikve=crkve*zlv(j)+cikve*xlv(j)
13796 crkve=crkveuk
13797 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13798 cikve=crkve*zlv(j)+cikve*xlv(j)
13799 crkve=crkveuk
13800 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13801 cikve=crkve*zlv(j)+cikve*xlv(j)
13802 crkve=crkveuk
13803 crkveuk=crkve*xlv(j)-cikve*zlv(j)
13804 cikve=crkve*zlv(j)+cikve*xlv(j)
13805 crkve=crkveuk
13806 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
13807 &stracks(i)*crkve)
13808 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
13809 &stracks(i)*cikve)
13810 480 continue
13811 goto 490
13812 680 continue
13813 do 690 j=1,napx
13814 if(ibbc.eq.0) then
13815 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
13816 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
13817 else
13818 crkveb(j)= &
13819 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
13820 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
13821 cikveb(j)= &
13822 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
13823 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
13824 endif
13825 rho2b(j)=crkveb(j)*crkveb(j)+cikveb(j)*cikveb(j)
13826 if(rho2b(j).le.pieni) &
13827 &goto 690
13828 tkb(j)=rho2b(j)/(two*sigman2(1,imbb(i)))
13829 if(ibbc.eq.0) then
13830 yv(1,j)=yv(1,j)+oidpsv(j)*(strack(i)*crkveb(j)/rho2b(j)* &
13831 &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))
13832 yv(2,j)=yv(2,j)+oidpsv(j)*(strack(i)*cikveb(j)/rho2b(j)* &
13833 &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))
13834 else
13835 cccc=(strack(i)*crkveb(j)/rho2b(j)* &
13836 &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))*bbcu(imbb(i),11)- &
13837 &(strack(i)*cikveb(j)/rho2b(j)* &
13838 &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
13839 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
13840 cccc=(strack(i)*crkveb(j)/rho2b(j)* &
13841 &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))*bbcu(imbb(i),12)+ &
13842 &(strack(i)*cikveb(j)/rho2b(j)* &
13843 &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
13844 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
13845 endif
13846 690 continue
13847 goto 490
13848 700 continue
13849 if(ibtyp.eq.0) then
13850 do j=1,napx
13851 r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
13852 rb(j)=sqrt(r2b(j))
13853 rkb(j)=strack(i)*pisqrt/rb(j)
13854 if(ibbc.eq.0) then
13855 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
13856 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
13857 else
13858 crkveb(j)= &
13859 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
13860 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
13861 cikveb(j)= &
13862 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
13863 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
13864 endif
13865 xrb(j)=abs(crkveb(j))/rb(j)
13866 zrb(j)=abs(cikveb(j))/rb(j)
13867 call errf(xrb(j),zrb(j),crxb(j),crzb(j))
13868 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
13869 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
13870 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
13871 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
13872 call errf(xbb(j),zbb(j),cbxb(j),cbzb(j))
13873 if(ibbc.eq.0) then
13874 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
13875 &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
13876 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
13877 &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
13878 else
13879 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
13880 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
13881 &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
13882 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
13883 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
13884 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
13885 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
13886 &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
13887 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
13888 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
13889 endif
13890 enddo
13891 else if(ibtyp.eq.1) then
13892 do j=1,napx
13893 r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
13894 rb(j)=sqrt(r2b(j))
13895 rkb(j)=strack(i)*pisqrt/rb(j)
13896 if(ibbc.eq.0) then
13897 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
13898 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
13899 else
13900 crkveb(j)= &
13901 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
13902 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
13903 cikveb(j)= &
13904 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
13905 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
13906 endif
13907 xrb(j)=abs(crkveb(j))/rb(j)
13908 zrb(j)=abs(cikveb(j))/rb(j)
13909 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
13910 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
13911 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
13912 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
13913 enddo
13914 call wzsubv(napx,xrb(1),zrb(1),crxb(1),crzb(1))
13915 call wzsubv(napx,xbb(1),zbb(1),cbxb(1),cbzb(1))
13916 do j=1,napx
13917 if(ibbc.eq.0) then
13918 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
13919 &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
13920 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
13921 &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
13922 else
13923 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
13924 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
13925 &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
13926 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
13927 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
13928 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
13929 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
13930 &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
13931 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
13932 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
13933 endif
13934 enddo
13935 endif
13936 goto 490
13937 720 continue
13938 if(ibtyp.eq.0) then
13939 do j=1,napx
13940 r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
13941 rb(j)=sqrt(r2b(j))
13942 rkb(j)=strack(i)*pisqrt/rb(j)
13943 if(ibbc.eq.0) then
13944 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
13945 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
13946 else
13947 crkveb(j)= &
13948 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
13949 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
13950 cikveb(j)= &
13951 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
13952 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
13953 endif
13954 xrb(j)=abs(crkveb(j))/rb(j)
13955 zrb(j)=abs(cikveb(j))/rb(j)
13956 call errf(zrb(j),xrb(j),crzb(j),crxb(j))
13957 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
13958 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
13959 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
13960 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
13961 call errf(zbb(j),xbb(j),cbzb(j),cbxb(j))
13962 if(ibbc.eq.0) then
13963 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
13964 &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
13965 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
13966 &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
13967 else
13968 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
13969 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
13970 &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
13971 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
13972 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
13973 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
13974 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
13975 &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
13976 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
13977 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
13978 endif
13979 enddo
13980 else if(ibtyp.eq.1) then
13981 do j=1,napx
13982 r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
13983 rb(j)=sqrt(r2b(j))
13984 rkb(j)=strack(i)*pisqrt/rb(j)
13985 if(ibbc.eq.0) then
13986 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
13987 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
13988 else
13989 crkveb(j)= &
13990 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
13991 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
13992 cikveb(j)= &
13993 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
13994 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
13995 endif
13996 xrb(j)=abs(crkveb(j))/rb(j)
13997 zrb(j)=abs(cikveb(j))/rb(j)
13998 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
13999 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
14000 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
14001 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
14002 enddo
14003 call wzsubv(napx,zrb(1),xrb(1),crzb(1),crxb(1))
14004 call wzsubv(napx,zbb(1),xbb(1),cbzb(1),cbxb(1))
14005 do j=1,napx
14006 if(ibbc.eq.0) then
14007 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
14008 &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
14009 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
14010 &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
14011 else
14012 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
14013 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
14014 &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
14015 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
14016 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
14017 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
14018 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
14019 &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
14020 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
14021 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
14022 endif
14023 enddo
14024 endif
14025 goto 490
14026 730 continue
14027 !--Hirata's 6D beam-beam kick
14028 do j=1,napx
14029 track6d(1,j)=(xv(1,j)+ed(ix)-clobeam(1,imbb(i)))*c1m3
14030 track6d(2,j)=(yv(1,j)/oidpsv(j)-clobeam(4,imbb(i)))*c1m3
14031 track6d(3,j)=(xv(2,j)+ek(ix)-clobeam(2,imbb(i)))*c1m3
14032 track6d(4,j)=(yv(2,j)/oidpsv(j)-clobeam(5,imbb(i)))*c1m3
14033 track6d(5,j)=(sigmv(j)-clobeam(3,imbb(i)))*c1m3
14034 track6d(6,j)=dpsv(j)-clobeam(6,imbb(i))
14035 enddo
14036 call beamint(napx,track6d,parbe,sigz,bbcu,imbb(i),ix,ibtyp, &
14037 &ibbc)
14038 do j=1,napx
14039 xv(1,j)=track6d(1,j)*c1e3+clobeam(1,imbb(i))- &
14040 &beamoff(1,imbb(i))
14041 xv(2,j)=track6d(3,j)*c1e3+clobeam(2,imbb(i))- &
14042 &beamoff(2,imbb(i))
14043 dpsv(j)=track6d(6,j)+clobeam(6,imbb(i))-beamoff(6,imbb(i))
14044 oidpsv(j)=one/(one+dpsv(j))
14045 yv(1,j)=(track6d(2,j)*c1e3+clobeam(4,imbb(i))- &
14046 &beamoff(4,imbb(i)))*oidpsv(j)
14047 yv(2,j)=(track6d(4,j)*c1e3+clobeam(5,imbb(i))- &
14048 &beamoff(5,imbb(i)))*oidpsv(j)
14049 ejfv(j)=dpsv(j)*e0f+e0f
14050 ejv(j)=sqrt(ejfv(j)*ejfv(j)+pma*pma)
14051 rvv(j)=(ejv(j)*e0f)/(e0*ejfv(j))
14052 if(ithick.eq.1) call envarsv(dpsv,oidpsv,rvv,ekv)
14053 enddo
14054 goto 490
14055 740 continue
14056 irrtr=imtr(ix)
14057 do j=1,napx
14058 sigmv(j)=sigmv(j)+cotr(irrtr,5)+rrtr(irrtr,5,1)*xv(1,j)+ &
14059 &rrtr(irrtr,5,2)*yv(1,j)+rrtr(irrtr,5,3)*xv(2,j)+ &
14060 &rrtr(irrtr,5,4)*yv(2,j)
14061 pux=xv(1,j)
14062 dpsv3(j)=dpsv(j)*c1e3
14063 xv(1,j)=cotr(irrtr,1)+rrtr(irrtr,1,1)*pux+ &
14064 &rrtr(irrtr,1,2)*yv(1,j)+idz(1)*dpsv3(j)*rrtr(irrtr,1,6)
14065 yv(1,j)=cotr(irrtr,2)+rrtr(irrtr,2,1)*pux+ &
14066 &rrtr(irrtr,2,2)*yv(1,j)+idz(1)*dpsv3(j)*rrtr(irrtr,2,6)
14067 pux=xv(2,j)
14068 xv(2,j)=cotr(irrtr,3)+rrtr(irrtr,3,3)*pux+ &
14069 &rrtr(irrtr,3,4)*yv(2,j)+idz(2)*dpsv3(j)*rrtr(irrtr,3,6)
14070 yv(2,j)=cotr(irrtr,4)+rrtr(irrtr,4,3)*pux+ &
14071 &rrtr(irrtr,4,4)*yv(2,j)+idz(2)*dpsv3(j)*rrtr(irrtr,4,6)
14072 enddo
14073
14074 !----------------------------------------------------------------------
14075
14076 ! Wire.
14077
14078 goto 490
14079 745 continue
14080 xory=1
14081 nfree=nturn1(ix)
14082 if(n.gt.nfree) then
14083 nac=n-nfree
14084 pi=4d0*atan(1d0)
14085 !---------ACdipAmp input in Tesla*meter converted to KeV/c
14086 !---------ejfv(j) should be in MeV/c --> ACdipAmp/ejfv(j) is in mrad
14087 acdipamp=ed(ix)*clight*1.0d-3
14088 !---------Qd input in tune units
14089 qd=ek(ix)
14090 !---------ACphase input in radians
14091 acphase=acdipph(ix)
14092 nramp1=nturn2(ix)
14093 nplato=nturn3(ix)
14094 nramp2=nturn4(ix)
14095 do j=1,napx
14096 if (xory.eq.1) then
14097 acdipamp2=acdipamp*tilts(i)
14098 acdipamp1=acdipamp*tiltc(i)
14099 else
14100 acdipamp2=acdipamp*tiltc(i)
14101 acdipamp1=-acdipamp*tilts(i)
14102 endif
14103 if(nramp1.gt.nac) then
14104 yv(1,j)=yv(1,j)+acdipamp1* &
14105 &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
14106 yv(2,j)=yv(2,j)+acdipamp2* &
14107 &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
14108 endif
14109 if(nac.ge.nramp1.and.(nramp1+nplato).gt.nac) then
14110 yv(1,j)=yv(1,j)+acdipamp1* &
14111 &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
14112 yv(2,j)=yv(2,j)+acdipamp2* &
14113 &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
14114 endif
14115 if(nac.ge.(nramp1+nplato).and.(nramp2+nramp1+nplato).gt. &
14116 &nac)then
14117 yv(1,j)=yv(1,j)+acdipamp1*sin(2d0*pi*qd*nac+acphase)* &
14118 &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
14119 yv(2,j)=yv(2,j)+acdipamp2*sin(2d0*pi*qd*nac+acphase)* &
14120 &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
14121 endif
14122 enddo
14123 endif
14124 goto 490
14125 746 continue
14126 xory=2
14127 nfree=nturn1(ix)
14128 if(n.gt.nfree) then
14129 nac=n-nfree
14130 pi=4d0*atan(1d0)
14131 !---------ACdipAmp input in Tesla*meter converted to KeV/c
14132 !---------ejfv(j) should be in MeV/c --> ACdipAmp/ejfv(j) is in mrad
14133 acdipamp=ed(ix)*clight*1.0d-3
14134 !---------Qd input in tune units
14135 qd=ek(ix)
14136 !---------ACphase input in radians
14137 acphase=acdipph(ix)
14138 nramp1=nturn2(ix)
14139 nplato=nturn3(ix)
14140 nramp2=nturn4(ix)
14141 do j=1,napx
14142 if (xory.eq.1) then
14143 acdipamp2=acdipamp*tilts(i)
14144 acdipamp1=acdipamp*tiltc(i)
14145 else
14146 acdipamp2=acdipamp*tiltc(i)
14147 acdipamp1=-acdipamp*tilts(i)
14148 endif
14149 if(nramp1.gt.nac) then
14150 yv(1,j)=yv(1,j)+acdipamp1* &
14151 &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
14152 yv(2,j)=yv(2,j)+acdipamp2* &
14153 &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
14154 endif
14155 if(nac.ge.nramp1.and.(nramp1+nplato).gt.nac) then
14156 yv(1,j)=yv(1,j)+acdipamp1* &
14157 &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
14158 yv(2,j)=yv(2,j)+acdipamp2* &
14159 &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
14160 endif
14161 if(nac.ge.(nramp1+nplato).and.(nramp2+nramp1+nplato).gt. &
14162 &nac)then
14163 yv(1,j)=yv(1,j)+acdipamp1*sin(2d0*pi*qd*nac+acphase)* &
14164 &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
14165 yv(2,j)=yv(2,j)+acdipamp2*sin(2d0*pi*qd*nac+acphase)* &
14166 &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
14167 endif
14168 enddo
14169 endif
14170 goto 490
14171
14172 !----------------------------
14173
14174 ! Wire.
14175
14176 748 continue
14177 ! magnetic rigidity
14178 chi = sqrt(e0*e0-pmap*pmap)*c1e6/clight
14179
14180 ix = ixcav
14181 tx = xrms(ix)
14182 ty = zrms(ix)
14183 dx = xpl(ix)
14184 dy = zpl(ix)
14185 embl = ek(ix)
14186 l = wirel(ix)
14187 cur = ed(ix)
14188
14189 leff = embl/cos(tx)/cos(ty)
14190 rx = dx *cos(tx)-embl*sin(tx)/2
14191 lin= dx *sin(tx)+embl*cos(tx)/2
14192 ry = dy *cos(ty)-lin *sin(ty)
14193 lin= lin*cos(ty)+dy *sin(ty)
14194
14195 do 750 j=1, napx
14196
14197 xv(1,j) = xv(1,j) * c1m3
14198 xv(2,j) = xv(2,j) * c1m3
14199 yv(1,j) = yv(1,j) * c1m3
14200 yv(2,j) = yv(2,j) * c1m3
14201
14202 ! print *, 'Start: ',j,xv(1,j),xv(2,j),yv(1,j),
14203 ! &yv(2,j)
14204
14205 ! call drift(-embl/2)
14206
14207 xv(1,j) = xv(1,j) - embl/2*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
14208 &yv(2,j)**2)
14209 xv(2,j) = xv(2,j) - embl/2*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
14210 &yv(2,j)**2)
14211
14212 ! call tilt(tx,ty)
14213
14214 xv(2,j) = xv(2,j)-xv(1,j)*sin(tx)*yv(2,j)/sqrt((1+dpsv(j))**2- &
14215 &yv(2,j)**2)/cos(atan(yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
14216 &yv(2,j)**2))-tx)
14217 xv(1,j) = xv(1,j)*(cos(tx)-sin(tx)*tan(atan(yv(1,j)/ &
14218 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-tx))
14219 yv(1,j) = sqrt((1+dpsv(j))**2-yv(2,j)**2)*sin(atan(yv(1,j)/ &
14220 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-tx)
14221
14222 xv(1,j) = xv(1,j)-xv(2,j)*sin(ty)*yv(1,j)/sqrt((1+dpsv(j))**2- &
14223 &yv(1,j)**2)/cos(atan(yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
14224 &yv(2,j)**2))-ty)
14225 xv(2,j) = xv(2,j)*(cos(ty)-sin(ty)*tan(atan(yv(2,j)/ &
14226 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-ty))
14227 yv(2,j) = sqrt((1+dpsv(j))**2-yv(1,j)**2)*sin(atan(yv(2,j)/ &
14228 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-ty)
14229
14230 ! call drift(lin)
14231
14232 xv(1,j) = xv(1,j) + lin*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
14233 &yv(2,j)**2)
14234 xv(2,j) = xv(2,j) + lin*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
14235 &yv(2,j)**2)
14236
14237 ! call kick(l,cur,lin,rx,ry,chi)
14238
14239 xi = xv(1,j)-rx
14240 yi = xv(2,j)-ry
14241 yv(1,j) = yv(1,j)-1.0d-7*cur/chi*xi/(xi**2+yi**2)* &
14242 &(sqrt((lin+l)**2+xi**2+yi**2)-sqrt((lin-l)**2+ &
14243 &xi**2+yi**2))
14244 !GRD FOR CONSISTENSY
14245 ! yv(2,j) = yv(2,j)-1e-7*cur/chi*yi/(xi**2+yi**2)* &
14246 yv(2,j) = yv(2,j)-1.0d-7*cur/chi*yi/(xi**2+yi**2)* &
14247 &(sqrt((lin+l)**2+xi**2+yi**2)-sqrt((lin-l)**2+ &
14248 &xi**2+yi**2))
14249
14250 ! call drift(leff-lin)
14251
14252 xv(1,j) = xv(1,j) + (leff-lin)*yv(1,j)/sqrt((1+dpsv(j))**2- &
14253 &yv(1,j)**2-yv(2,j)**2)
14254 xv(2,j) = xv(2,j) + (leff-lin)*yv(2,j)/sqrt((1+dpsv(j))**2- &
14255 &yv(1,j)**2-yv(2,j)**2)
14256
14257 ! call invtilt(tx,ty)
14258
14259 xv(1,j) = xv(1,j)-xv(2,j)*sin(-ty)*yv(1,j)/sqrt((1+dpsv(j))**2- &
14260 &yv(1,j)**2)/cos(atan(yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
14261 &yv(2,j)**2))+ty)
14262 xv(2,j) = xv(2,j)*(cos(-ty)-sin(-ty)*tan(atan(yv(2,j)/ &
14263 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+ty))
14264 yv(2,j) = sqrt((1+dpsv(j))**2-yv(1,j)**2)*sin(atan(yv(2,j)/ &
14265 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+ty)
14266
14267 xv(2,j) = xv(2,j)-xv(1,j)*sin(-tx)*yv(2,j)/sqrt((1+dpsv(j))**2- &
14268 &yv(2,j)**2)/cos(atan(yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
14269 &yv(2,j)**2))+tx)
14270 xv(1,j) = xv(1,j)*(cos(-tx)-sin(-tx)*tan(atan(yv(1,j)/ &
14271 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+tx))
14272 yv(1,j) = sqrt((1+dpsv(j))**2-yv(2,j)**2)*sin(atan(yv(1,j)/ &
14273 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+tx)
14274
14275 ! call shift(-embl*tan(tx),-embl*tan(ty)/cos(tx))
14276
14277 xv(1,j) = xv(1,j) + embl*tan(tx)
14278 xv(2,j) = xv(2,j) + embl*tan(ty)/cos(tx)
14279
14280 ! call drift(-embl/2)
14281
14282 xv(1,j) = xv(1,j) - embl/2*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
14283 &yv(2,j)**2)
14284 xv(2,j) = xv(2,j) - embl/2*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
14285 &yv(2,j)**2)
14286
14287 xv(1,j) = xv(1,j) * c1e3
14288 xv(2,j) = xv(2,j) * c1e3
14289 yv(1,j) = yv(1,j) * c1e3
14290 yv(2,j) = yv(2,j) * c1e3
14291
14292 ! print *, 'End: ',j,xv(1,j),xv(2,j),yv(1,j),
14293 ! &yv(2,j)
14294
14295 !-----------------------------------------------------------------------
14296
14297 750 continue
14298 goto 490
14299
14300 !----------------------------
14301
14302 490 continue
14303 llost=.false.
14304 do j=1,napx
14305 llost=llost.or. &
14306 &abs(xv(1,j)).gt.aper(1).or.abs(xv(2,j)).gt.aper(2)
14307 enddo
14308 if (llost) then
14309 kpz=abs(kp(ix))
14310 if(kpz.eq.2) then
14311 call lostpar3(i,ix,nthinerr)
14312 if(nthinerr.ne.0) return
14313 elseif(kpz.eq.3) then
14314 call lostpar4(i,ix,nthinerr)
14315 if(nthinerr.ne.0) return
14316 else
14317 call lostpar2(i,ix,nthinerr)
14318 if(nthinerr.ne.0) return
14319 endif
14320 endif
14321 500 continue
14322 call lostpart(nthinerr)
14323 if(nthinerr.ne.0) return
14324 if(ntwin.ne.2) call dist1
14325 if(mod(n,nwr(4)).eq.0) call write6(n)
14326 510 continue
14327 return
14328 end
14329 subroutine thck6dua(nthinerr)
14330 !-----------------------------------------------------------------------
14331 !
14332 ! TRACK THICK LENS 6D WITH ACCELERATION
14333 !
14334 !
14335 ! F. SCHMIDT
14336 !-----------------------------------------------------------------------
14337 implicit none
14338 integer i,idz1,idz2,irrtr,ix,j,jb,jmel,jx,k,kpz,n,nmz,nthinerr
14339 double precision cbxb,cbzb,cccc,cikve,cikveb,crkve,crkveb,crkveuk,&
14340 &crxb,crzb,dpsv3,e0fo,e0o,pux,puxve1,puxve2,puzve1,puzve2,r0,r2b, &
14341 &rb,rho2b,rkb,tkb,xbb,xlvj,xrb,yv1j,yv2j,zbb,zlvj,zrb
14342 integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1, &
14343 &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran, &
14344 &nrco,ntr,nzfz
14345 parameter(npart = 64,nmac = 1)
14346 parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000, &
14347 &nzfz = 300000,mmul = 11)
14348 parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5, &
14349 &nema = 15)
14350 parameter(mcor = 10,mcop = mcor+6, mbea = 15)
14351 parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
14352 parameter(nmon1 = 600,ncor1 = 600)
14353 parameter(ntr = 20,nbb = 160)
14354 integer ireturn, xory, nac, nfree, nramp1,nplato, nramp2
14355 double precision xv1j,xv2j
14356 double precision acdipamp, qd, acphase,acdipamp2, &
14357 &acdipamp1
14358 double precision l,cur,dx,dy,tx,ty,embl,leff,rx,ry,lin,chi,xi,yi
14359 logical llost
14360 double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3, &
14361 &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21, &
14362 &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
14363 &one,pieni,pmae,pmap,three,two,zero
14364 parameter(pieni = 1d-38)
14365 parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
14366 parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
14367 parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
14368 parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
14369 parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 = &
14370 &1.0d16)
14371 parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
14372 parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
14373 parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
14374 parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
14375 parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
14376 parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
14377 parameter(pmap = 938.271998d0,pmae = .510998902d0)
14378 parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
14379 integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo, &
14380 &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor, &
14381 &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb, &
14382 &imc,imtr,iorg,iout, &
14383 &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires, &
14384 &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw, &
14385 &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox, &
14386 &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo, &
14387 &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx, &
14388 &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr, &
14389 &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew, &
14390 &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr, &
14391 &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
14392 double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu, &
14393 &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
14394 &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft, &
14395 &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
14396 &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign, &
14397 &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum, &
14398 &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
14399 &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph, &
14400 &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
14401 &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel, &
14402 &acdipph
14403 real hmal
14404 character*16 bez,bezb,bezr,erbez,bezl
14405 character*80 toptit,sixtit,commen
14406 common/erro/ierro,erbez
14407 common/kons/pi,pi2,pisqrt,rad
14408 common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
14409 common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
14410 common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
14411 common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
14412 common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
14413 common/syos2/rvf(mpa)
14414 common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
14415 &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
14416 common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3), &
14417 &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen, &
14418 &iicav,itionc(nele),ition,idp,ncy,ixcav
14419 common/corcom/dpscor,sigcor,icode,idam,its6d
14420 common/multi/bk0(nele,mmul),ak0(nele,mmul), &
14421 &bka(nele,mmul),aka(nele,mmul)
14422 common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
14423 common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
14424 common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz), &
14425 &tilts(nblz),mout2,icext(nblz),icextal(nblz)
14426 common/beo /aper(2),di0(2),dip0(2),ta(6,6)
14427 common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
14428 &iout
14429 common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
14430 common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint, &
14431 &ntco,eui,euii,nlin,bezl(nele)
14432 common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2), &
14433 &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr, &
14434 &ncororb(nele)
14435 common/apert/apx(nele),apz(nele),ape(3,nele)
14436 common/clos/sigma0(2),iclo,ncorru,ncorrep
14437 common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20), &
14438 &ratioe(nele),iratioe(nele),icoe
14439 common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
14440 common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
14441 common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
14442 common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
14443 common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2, &
14444 &nstart,nstop,iskip,iconv,imad
14445 common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
14446 common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
14447 common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
14448 common/ripp2/nrturn
14449 common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
14450 common/pawc/hmal(nplo)
14451 common/tit/sixtit,commen,ithick
14452 common/co6d/clo6(3),clop6(3)
14453 common/dkic/dki(nele,3)
14454 common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb), &
14455 &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart), &
14456 &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar, &
14457 &nbeam,ibbc,ibeco,ibtyp,lhc
14458 common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
14459 common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
14460 common/wireco/ wirel(nele)
14461 common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele), &
14462 &nturn3(nele), nturn4(nele)
14463 integer idz,itra
14464 double precision al,as,chi0,chid,dp1,dps,exz,sigm
14465 common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa), &
14466 &dps(mpa),idz(2)
14467 common/anf/chi0,chid,exz(2,6),dp1,itra
14468 integer ichrom,is
14469 double precision alf0,amp,bet0,clo,clop,cro,x,y
14470 common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
14471 common/chrom/cro(2),is(2),ichrom
14472 integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
14473 &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
14474 double precision dpmax,preda,weig1,weig2
14475 character*16 coel
14476 common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
14477 common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
14478 common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
14479 &coel(10)
14480 double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
14481 &zsi
14482 real tlim,time0,time1
14483 common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz), &
14484 &aai(nblz,mmul),bbi(nblz,mmul)
14485 common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
14486 common/damp/damp,ampt
14487 common/ttime/tlim,time0,time1
14488 double precision tasm
14489 common/tasm/tasm(6,6)
14490 integer iv,ixv,nlostp,nms,numxv
14491 double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
14492 &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
14493 &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl, &
14494 &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
14495 &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv, &
14496 &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas, &
14497 &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
14498 &zsiv,zsv
14499 logical pstop
14500 common/main1/ &
14501 &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz), &
14502 &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz), &
14503 &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2), &
14504 &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart), &
14505 &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart), &
14506 &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart), &
14507 &xlv(npart),zlv(npart),pstop(npart),rvv(npart), &
14508 &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
14509 common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart), &
14510 &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart), &
14511 &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart), &
14512 &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart), &
14513 &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart), &
14514 &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
14515 &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
14516 &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart), &
14517 &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
14518 common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo), &
14519 &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart), &
14520 &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6), &
14521 &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
14522 integer numx
14523 double precision e0f
14524 common/main4/ e0f,numx
14525 integer ktrack,nwri
14526 double precision dpsv1,strack,strackc,stracks
14527 common/track/ ktrack(nblz),strack(nblz),strackc(nblz), &
14528 &stracks(nblz),dpsv1(npart),nwri
14529 double precision cc,xlim,ylim
14530 parameter(cc = 1.12837916709551d0)
14531 parameter(xlim = 5.33d0)
14532 parameter(ylim = 4.29d0)
14533 dimension crkveb(npart),cikveb(npart),rho2b(npart),tkb(npart), &
14534 &r2b(npart),rb(npart),rkb(npart), &
14535 &xrb(npart),zrb(npart),xbb(npart),zbb(npart),crxb(npart), &
14536 &crzb(npart),cbxb(npart),cbzb(npart)
14537 dimension dpsv3(npart)
14538 save
14539 !-----------------------------------------------------------------------
14540 nthinerr=0
14541 idz1=idz(1)
14542 idz2=idz(2)
14543 do 510 n=1,numl
14544 numx=n-1
14545 if(irip.eq.1) call ripple(n)
14546 if(n.le.nde(1)) nwri=nwr(1)
14547 if(n.gt.nde(1).and.n.le.nde(2)) nwri=nwr(2)
14548 if(n.gt.nde(2)) nwri=nwr(3)
14549 if(nwri.eq.0) nwri=numl+numlr+1
14550 if(mod(numx,nwri).eq.0) call writebin(nthinerr)
14551 if(nthinerr.ne.0) return
14552 do 500 i=1,iu
14553 if(ktrack(i).eq.1) then
14554 ix=ic(i)
14555 else
14556 ix=ic(i)-nblo
14557 endif
14558 !----------count 44
14559 goto(20,40,740,500,500,500,500,500,500,500,60,80,100,120, &
14560 &140,160,180,200,220,240,290,310,330,350,370,390,410,430, &
14561 &450,470,490,260,520,540,560,580,600,620,640,660,680,700,720 &
14562 &,730,748,500,500,500,500,500,745,746),ktrack(i)
14563 goto 500
14564 20 jmel=mel(ix)
14565 do 30 jb=1,jmel
14566 jx=mtyp(ix,jb)
14567 do 30 j=1,napx
14568 puxve1=xv(1,j)
14569 puzve1=yv(1,j)
14570 puxve2=xv(2,j)
14571 puzve2=yv(2,j)
14572 sigmv(j)=sigmv(j)+as(1,1,j,jx)+puxve1*(as(2,1,j,jx)+ as &
14573 &(4,1,j,jx)*puzve1+as(5,1,j,jx)*puxve1)+ puzve1*(as &
14574 &(3,1,j,jx)+as(6,1,j,jx)*puzve1) &
14575 &+as(1,2,j,jx)+puxve2*(as(2,2,j,jx)+ as &
14576 &(4,2,j,jx)*puzve2+as(5,2,j,jx)*puxve2)+ puzve2*(as &
14577 &(3,2,j,jx)+as(6,2,j,jx)*puzve2)
14578 xv(1,j)=al(1,1,j,jx)*puxve1+ al(2,1,j,jx)*puzve1+idz1*al&
14579 &(5,1,j,jx)
14580 xv(2,j)=al(1,2,j,jx)*puxve2+ al(2,2,j,jx)*puzve2+idz2*al&
14581 &(5,2,j,jx)
14582 yv(1,j)=al(3,1,j,jx)*puxve1+ al(4,1,j,jx)*puzve1+idz1*al&
14583 &(6,1,j,jx)
14584 yv(2,j)=al(3,2,j,jx)*puxve2+ al(4,2,j,jx)*puzve2+idz2*al&
14585 &(6,2,j,jx)
14586 30 continue
14587 goto 500
14588 40 e0o=e0
14589 e0fo=e0f
14590 call adia(n,e0f)
14591 do 50 j=1,napx
14592 ejf0v(j)=ejfv(j)
14593 if(abs(dppoff).gt.pieni) sigmv(j)=sigmv(j)-sigmoff(i)
14594 if(sigmv(j).lt.zero) sigmv(j)=e0f*e0o/(e0fo*e0)*sigmv(j)
14595 if(kz(ix).eq.12) then
14596 ejv(j)=ejv(j)+ed(ix)*sin(hsyc(ix)*sigmv(j)+phas+ &
14597 &phasc(ix))
14598 else
14599 ejv(j)=ejv(j)+hsy(1)*sin(hsy(3)*sigmv(j)+phas)
14600 endif
14601 ejfv(j)=sqrt(ejv(j)*ejv(j)-pma*pma)
14602 rvv(j)=(ejv(j)*e0f)/(e0*ejfv(j))
14603 dpsv(j)=(ejfv(j)-e0f)/e0f
14604 oidpsv(j)=one/(one+dpsv(j))
14605 dpsv1(j)=dpsv(j)*c1e3*oidpsv(j)
14606 if(sigmv(j).gt.zero) sigmv(j)=e0f*e0o/(e0fo*e0)*sigmv(j)
14607 yv(1,j)=ejf0v(j)/ejfv(j)*yv(1,j)
14608 50 yv(2,j)=ejf0v(j)/ejfv(j)*yv(2,j)
14609 if(n.eq.1) write(98,'(1p,6(2x,e25.18))') &
14610 &(xv(1,j),yv(1,j),xv(2,j),yv(2,j),sigmv(j),dpsv(j), &
14611 &j=1,napx)
14612 call synuthck
14613 goto 490
14614 !--HORIZONTAL DIPOLE
14615 60 do 70 j=1,napx
14616 yv(1,j)=yv(1,j)+strackc(i)*oidpsv(j)
14617 yv(2,j)=yv(2,j)+stracks(i)*oidpsv(j)
14618 70 continue
14619 goto 490
14620 !--NORMAL QUADRUPOLE
14621 80 do 90 j=1,napx
14622 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
14623 &(xv(2,j)-zsiv(1,i))*tilts(i)
14624 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
14625 &(xv(2,j)-zsiv(1,i))*tiltc(i)
14626 crkve=xlv(j)
14627 cikve=zlv(j)
14628 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
14629 &stracks(i)*cikve)
14630 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
14631 &stracks(i)*crkve)
14632 90 continue
14633 goto 490
14634 !--NORMAL SEXTUPOLE
14635 100 do 110 j=1,napx
14636 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
14637 &(xv(2,j)-zsiv(1,i))*tilts(i)
14638 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
14639 &(xv(2,j)-zsiv(1,i))*tiltc(i)
14640 crkve=xlv(j)
14641 cikve=zlv(j)
14642 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14643 cikve=crkve*zlv(j)+cikve*xlv(j)
14644 crkve=crkveuk
14645 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
14646 &stracks(i)*cikve)
14647 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
14648 &stracks(i)*crkve)
14649 110 continue
14650 goto 490
14651 !--NORMAL OCTUPOLE
14652 120 do 130 j=1,napx
14653 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
14654 &(xv(2,j)-zsiv(1,i))*tilts(i)
14655 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
14656 &(xv(2,j)-zsiv(1,i))*tiltc(i)
14657 crkve=xlv(j)
14658 cikve=zlv(j)
14659 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14660 cikve=crkve*zlv(j)+cikve*xlv(j)
14661 crkve=crkveuk
14662 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14663 cikve=crkve*zlv(j)+cikve*xlv(j)
14664 crkve=crkveuk
14665 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
14666 &stracks(i)*cikve)
14667 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
14668 &stracks(i)*crkve)
14669 130 continue
14670 goto 490
14671 !--NORMAL DECAPOLE
14672 140 do 150 j=1,napx
14673 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
14674 &(xv(2,j)-zsiv(1,i))*tilts(i)
14675 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
14676 &(xv(2,j)-zsiv(1,i))*tiltc(i)
14677 crkve=xlv(j)
14678 cikve=zlv(j)
14679 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14680 cikve=crkve*zlv(j)+cikve*xlv(j)
14681 crkve=crkveuk
14682 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14683 cikve=crkve*zlv(j)+cikve*xlv(j)
14684 crkve=crkveuk
14685 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14686 cikve=crkve*zlv(j)+cikve*xlv(j)
14687 crkve=crkveuk
14688 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
14689 &stracks(i)*cikve)
14690 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
14691 &stracks(i)*crkve)
14692 150 continue
14693 goto 490
14694 !--NORMAL DODECAPOLE
14695 160 do 170 j=1,napx
14696 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
14697 &(xv(2,j)-zsiv(1,i))*tilts(i)
14698 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
14699 &(xv(2,j)-zsiv(1,i))*tiltc(i)
14700 crkve=xlv(j)
14701 cikve=zlv(j)
14702 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14703 cikve=crkve*zlv(j)+cikve*xlv(j)
14704 crkve=crkveuk
14705 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14706 cikve=crkve*zlv(j)+cikve*xlv(j)
14707 crkve=crkveuk
14708 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14709 cikve=crkve*zlv(j)+cikve*xlv(j)
14710 crkve=crkveuk
14711 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14712 cikve=crkve*zlv(j)+cikve*xlv(j)
14713 crkve=crkveuk
14714 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
14715 &stracks(i)*cikve)
14716 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
14717 &stracks(i)*crkve)
14718 170 continue
14719 goto 490
14720 !--NORMAL 14-POLE
14721 180 do 190 j=1,napx
14722 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
14723 &(xv(2,j)-zsiv(1,i))*tilts(i)
14724 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
14725 &(xv(2,j)-zsiv(1,i))*tiltc(i)
14726 crkve=xlv(j)
14727 cikve=zlv(j)
14728 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14729 cikve=crkve*zlv(j)+cikve*xlv(j)
14730 crkve=crkveuk
14731 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14732 cikve=crkve*zlv(j)+cikve*xlv(j)
14733 crkve=crkveuk
14734 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14735 cikve=crkve*zlv(j)+cikve*xlv(j)
14736 crkve=crkveuk
14737 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14738 cikve=crkve*zlv(j)+cikve*xlv(j)
14739 crkve=crkveuk
14740 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14741 cikve=crkve*zlv(j)+cikve*xlv(j)
14742 crkve=crkveuk
14743 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
14744 &stracks(i)*cikve)
14745 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
14746 &stracks(i)*crkve)
14747 190 continue
14748 goto 490
14749 !--NORMAL 16-POLE
14750 200 do 210 j=1,napx
14751 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
14752 &(xv(2,j)-zsiv(1,i))*tilts(i)
14753 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
14754 &(xv(2,j)-zsiv(1,i))*tiltc(i)
14755 crkve=xlv(j)
14756 cikve=zlv(j)
14757 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14758 cikve=crkve*zlv(j)+cikve*xlv(j)
14759 crkve=crkveuk
14760 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14761 cikve=crkve*zlv(j)+cikve*xlv(j)
14762 crkve=crkveuk
14763 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14764 cikve=crkve*zlv(j)+cikve*xlv(j)
14765 crkve=crkveuk
14766 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14767 cikve=crkve*zlv(j)+cikve*xlv(j)
14768 crkve=crkveuk
14769 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14770 cikve=crkve*zlv(j)+cikve*xlv(j)
14771 crkve=crkveuk
14772 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14773 cikve=crkve*zlv(j)+cikve*xlv(j)
14774 crkve=crkveuk
14775 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
14776 &stracks(i)*cikve)
14777 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
14778 &stracks(i)*crkve)
14779 210 continue
14780 goto 490
14781 !--NORMAL 18-POLE
14782 220 do 230 j=1,napx
14783 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
14784 &(xv(2,j)-zsiv(1,i))*tilts(i)
14785 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
14786 &(xv(2,j)-zsiv(1,i))*tiltc(i)
14787 crkve=xlv(j)
14788 cikve=zlv(j)
14789 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14790 cikve=crkve*zlv(j)+cikve*xlv(j)
14791 crkve=crkveuk
14792 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14793 cikve=crkve*zlv(j)+cikve*xlv(j)
14794 crkve=crkveuk
14795 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14796 cikve=crkve*zlv(j)+cikve*xlv(j)
14797 crkve=crkveuk
14798 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14799 cikve=crkve*zlv(j)+cikve*xlv(j)
14800 crkve=crkveuk
14801 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14802 cikve=crkve*zlv(j)+cikve*xlv(j)
14803 crkve=crkveuk
14804 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14805 cikve=crkve*zlv(j)+cikve*xlv(j)
14806 crkve=crkveuk
14807 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14808 cikve=crkve*zlv(j)+cikve*xlv(j)
14809 crkve=crkveuk
14810 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
14811 &stracks(i)*cikve)
14812 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
14813 &stracks(i)*crkve)
14814 230 continue
14815 goto 490
14816 !--NORMAL 20-POLE
14817 240 do 250 j=1,napx
14818 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
14819 &(xv(2,j)-zsiv(1,i))*tilts(i)
14820 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
14821 &(xv(2,j)-zsiv(1,i))*tiltc(i)
14822 crkve=xlv(j)
14823 cikve=zlv(j)
14824 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14825 cikve=crkve*zlv(j)+cikve*xlv(j)
14826 crkve=crkveuk
14827 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14828 cikve=crkve*zlv(j)+cikve*xlv(j)
14829 crkve=crkveuk
14830 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14831 cikve=crkve*zlv(j)+cikve*xlv(j)
14832 crkve=crkveuk
14833 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14834 cikve=crkve*zlv(j)+cikve*xlv(j)
14835 crkve=crkveuk
14836 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14837 cikve=crkve*zlv(j)+cikve*xlv(j)
14838 crkve=crkveuk
14839 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14840 cikve=crkve*zlv(j)+cikve*xlv(j)
14841 crkve=crkveuk
14842 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14843 cikve=crkve*zlv(j)+cikve*xlv(j)
14844 crkve=crkveuk
14845 crkveuk=crkve*xlv(j)-cikve*zlv(j)
14846 cikve=crkve*zlv(j)+cikve*xlv(j)
14847 crkve=crkveuk
14848 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+ &
14849 &stracks(i)*cikve)
14850 yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+ &
14851 &stracks(i)*crkve)
14852 250 continue
14853 goto 490
14854 520 continue
14855 do 530 j=1,napx
14856 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
14857 &(xv(2,j)-zsiv(1,i))*tilts(i)
14858 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
14859 &(xv(2,j)-zsiv(1,i))*tiltc(i)
14860 yv(1,j)=yv(1,j)-(strack(i)*xlvj*oidpsv(j) &
14861 &+dpsv1(j))*dki(ix,1)*tiltc(i) &
14862 &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
14863 yv(2,j)=yv(2,j)-(strack(i)*xlvj*oidpsv(j) &
14864 &+dpsv1(j))*dki(ix,1)*tilts(i) &
14865 &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
14866 sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
14867 530 continue
14868 goto 490
14869 540 continue
14870 do 550 j=1,napx
14871 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
14872 &(xv(2,j)-zsiv(1,i))*tilts(i)
14873 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
14874 &(xv(2,j)-zsiv(1,i))*tiltc(i)
14875 yv(1,j)=yv(1,j)-(strack(i)*xlvj*oidpsv(j) &
14876 &+dpsv1(j))*dki(ix,1)*tiltc(i) &
14877 &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
14878 yv(2,j)=yv(2,j)-(strack(i)*xlvj*oidpsv(j) &
14879 &+dpsv1(j))*dki(ix,1)*tilts(i) &
14880 &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
14881 sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
14882 550 continue
14883 goto 260
14884 560 continue
14885 do 570 j=1,napx
14886 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
14887 &(xv(2,j)-zsiv(1,i))*tilts(i)
14888 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
14889 &(xv(2,j)-zsiv(1,i))*tiltc(i)
14890 yv(1,j)=yv(1,j)-strackc(i)*dpsv1(j) &
14891 &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
14892 yv(2,j)=yv(2,j)-stracks(i)*dpsv1(j) &
14893 &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
14894 sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
14895 570 continue
14896 goto 490
14897 580 continue
14898 do 590 j=1,napx
14899 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
14900 &(xv(2,j)-zsiv(1,i))*tilts(i)
14901 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
14902 &(xv(2,j)-zsiv(1,i))*tiltc(i)
14903 yv(1,j)=yv(1,j)-strackc(i)*dpsv1(j) &
14904 &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
14905 yv(2,j)=yv(2,j)-stracks(i)*dpsv1(j) &
14906 &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
14907 sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
14908 590 continue
14909 goto 260
14910 600 continue
14911 do 610 j=1,napx
14912 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
14913 &(xv(2,j)-zsiv(1,i))*tilts(i)
14914 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
14915 &(xv(2,j)-zsiv(1,i))*tiltc(i)
14916 yv(1,j)=yv(1,j)+(strack(i)*zlvj*oidpsv(j) &
14917 &-dpsv1(j))*dki(ix,2)*tilts(i) &
14918 &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
14919 yv(2,j)=yv(2,j)-(strack(i)*zlvj*oidpsv(j) &
14920 &-dpsv1(j))*dki(ix,2)*tiltc(i) &
14921 &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
14922 sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
14923 610 continue
14924 goto 490
14925 620 continue
14926 do 630 j=1,napx
14927 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
14928 &(xv(2,j)-zsiv(1,i))*tilts(i)
14929 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
14930 &(xv(2,j)-zsiv(1,i))*tiltc(i)
14931 yv(1,j)=yv(1,j)+(strack(i)*zlvj*oidpsv(j) &
14932 &-dpsv1(j))*dki(ix,2)*tilts(i) &
14933 &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
14934 yv(2,j)=yv(2,j)-(strack(i)*zlvj*oidpsv(j) &
14935 &-dpsv1(j))*dki(ix,2)*tiltc(i) &
14936 &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
14937 sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
14938 630 continue
14939 goto 260
14940 640 continue
14941 do 650 j=1,napx
14942 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
14943 &(xv(2,j)-zsiv(1,i))*tilts(i)
14944 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
14945 &(xv(2,j)-zsiv(1,i))*tiltc(i)
14946 yv(1,j)=yv(1,j)-stracks(i)*dpsv1(j) &
14947 &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
14948 yv(2,j)=yv(2,j)+strackc(i)*dpsv1(j) &
14949 &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
14950 sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
14951 650 continue
14952 goto 490
14953 660 continue
14954 do 670 j=1,napx
14955 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
14956 &(xv(2,j)-zsiv(1,i))*tilts(i)
14957 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
14958 &(xv(2,j)-zsiv(1,i))*tiltc(i)
14959 yv(1,j)=yv(1,j)-stracks(i)*dpsv1(j) &
14960 &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
14961 yv(2,j)=yv(2,j)+strackc(i)*dpsv1(j) &
14962 &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
14963 sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
14964 670 continue
14965 260 r0=ek(ix)
14966 nmz=nmu(ix)
14967 if(nmz.ge.2) then
14968 do 280 j=1,napx
14969 xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
14970 &(xv(2,j)-zsiv(1,i))*tilts(i)
14971 zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
14972 &(xv(2,j)-zsiv(1,i))*tiltc(i)
14973 yv1j=bbiv(1,1,i)+bbiv(2,1,i)*xlvj+aaiv(2,1,i)*zlvj
14974 yv2j=aaiv(1,1,i)-bbiv(2,1,i)*zlvj+aaiv(2,1,i)*xlvj
14975 crkve=xlvj
14976 cikve=zlvj
14977 do 270 k=3,nmz
14978 crkveuk=crkve*xlvj-cikve*zlvj
14979 cikve=crkve*zlvj+cikve*xlvj
14980 crkve=crkveuk
14981 yv1j=yv1j+bbiv(k,1,i)*crkve+aaiv(k,1,i)*cikve
14982 yv2j=yv2j-bbiv(k,1,i)*cikve+aaiv(k,1,i)*crkve
14983 270 continue
14984 yv(1,j)=yv(1,j)+(tiltc(i)*yv1j-tilts(i)*yv2j)*oidpsv(j)
14985 yv(2,j)=yv(2,j)+(tiltc(i)*yv2j+tilts(i)*yv1j)*oidpsv(j)
14986 280 continue
14987 else
14988 do 275 j=1,napx
14989 yv(1,j)=yv(1,j)+(tiltc(i)*bbiv(1,1,i)- &
14990 &tilts(i)*aaiv(1,1,i))*oidpsv(j)
14991 yv(2,j)=yv(2,j)+(tiltc(i)*aaiv(1,1,i)+ &
14992 &tilts(i)*bbiv(1,1,i))*oidpsv(j)
14993 275 continue
14994 endif
14995 goto 490
14996 !--SKEW ELEMENTS
14997 !--VERTICAL DIPOLE
14998 290 do 300 j=1,napx
14999 yv(1,j)=yv(1,j)-stracks(i)*oidpsv(j)
15000 yv(2,j)=yv(2,j)+strackc(i)*oidpsv(j)
15001 300 continue
15002 goto 490
15003 !--SKEW QUADRUPOLE
15004 310 do 320 j=1,napx
15005 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
15006 &(xv(2,j)-zsiv(1,i))*tilts(i)
15007 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
15008 &(xv(2,j)-zsiv(1,i))*tiltc(i)
15009 crkve=xlv(j)
15010 cikve=zlv(j)
15011 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
15012 &stracks(i)*crkve)
15013 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
15014 &stracks(i)*cikve)
15015 320 continue
15016 goto 490
15017 !--SKEW SEXTUPOLE
15018 330 do 340 j=1,napx
15019 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
15020 &(xv(2,j)-zsiv(1,i))*tilts(i)
15021 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
15022 &(xv(2,j)-zsiv(1,i))*tiltc(i)
15023 crkve=xlv(j)
15024 cikve=zlv(j)
15025 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15026 cikve=crkve*zlv(j)+cikve*xlv(j)
15027 crkve=crkveuk
15028 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
15029 &stracks(i)*crkve)
15030 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
15031 &stracks(i)*cikve)
15032 340 continue
15033 goto 490
15034 !--SKEW OCTUPOLE
15035 350 do 360 j=1,napx
15036 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
15037 &(xv(2,j)-zsiv(1,i))*tilts(i)
15038 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
15039 &(xv(2,j)-zsiv(1,i))*tiltc(i)
15040 crkve=xlv(j)
15041 cikve=zlv(j)
15042 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15043 cikve=crkve*zlv(j)+cikve*xlv(j)
15044 crkve=crkveuk
15045 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15046 cikve=crkve*zlv(j)+cikve*xlv(j)
15047 crkve=crkveuk
15048 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
15049 &stracks(i)*crkve)
15050 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
15051 &stracks(i)*cikve)
15052 360 continue
15053 goto 490
15054 !--SKEW DECAPOLE
15055 370 do 380 j=1,napx
15056 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
15057 &(xv(2,j)-zsiv(1,i))*tilts(i)
15058 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
15059 &(xv(2,j)-zsiv(1,i))*tiltc(i)
15060 crkve=xlv(j)
15061 cikve=zlv(j)
15062 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15063 cikve=crkve*zlv(j)+cikve*xlv(j)
15064 crkve=crkveuk
15065 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15066 cikve=crkve*zlv(j)+cikve*xlv(j)
15067 crkve=crkveuk
15068 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15069 cikve=crkve*zlv(j)+cikve*xlv(j)
15070 crkve=crkveuk
15071 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
15072 &stracks(i)*crkve)
15073 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
15074 &stracks(i)*cikve)
15075 380 continue
15076 goto 490
15077 !--SKEW DODECAPOLE
15078 390 do 400 j=1,napx
15079 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
15080 &(xv(2,j)-zsiv(1,i))*tilts(i)
15081 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
15082 &(xv(2,j)-zsiv(1,i))*tiltc(i)
15083 crkve=xlv(j)
15084 cikve=zlv(j)
15085 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15086 cikve=crkve*zlv(j)+cikve*xlv(j)
15087 crkve=crkveuk
15088 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15089 cikve=crkve*zlv(j)+cikve*xlv(j)
15090 crkve=crkveuk
15091 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15092 cikve=crkve*zlv(j)+cikve*xlv(j)
15093 crkve=crkveuk
15094 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15095 cikve=crkve*zlv(j)+cikve*xlv(j)
15096 crkve=crkveuk
15097 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
15098 &stracks(i)*crkve)
15099 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
15100 &stracks(i)*cikve)
15101 400 continue
15102 goto 490
15103 !--SKEW 14-POLE
15104 410 do 420 j=1,napx
15105 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
15106 &(xv(2,j)-zsiv(1,i))*tilts(i)
15107 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
15108 &(xv(2,j)-zsiv(1,i))*tiltc(i)
15109 crkve=xlv(j)
15110 cikve=zlv(j)
15111 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15112 cikve=crkve*zlv(j)+cikve*xlv(j)
15113 crkve=crkveuk
15114 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15115 cikve=crkve*zlv(j)+cikve*xlv(j)
15116 crkve=crkveuk
15117 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15118 cikve=crkve*zlv(j)+cikve*xlv(j)
15119 crkve=crkveuk
15120 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15121 cikve=crkve*zlv(j)+cikve*xlv(j)
15122 crkve=crkveuk
15123 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15124 cikve=crkve*zlv(j)+cikve*xlv(j)
15125 crkve=crkveuk
15126 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
15127 &stracks(i)*crkve)
15128 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
15129 &stracks(i)*cikve)
15130 420 continue
15131 goto 490
15132 !--SKEW 16-POLE
15133 430 do 440 j=1,napx
15134 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
15135 &(xv(2,j)-zsiv(1,i))*tilts(i)
15136 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
15137 &(xv(2,j)-zsiv(1,i))*tiltc(i)
15138 crkve=xlv(j)
15139 cikve=zlv(j)
15140 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15141 cikve=crkve*zlv(j)+cikve*xlv(j)
15142 crkve=crkveuk
15143 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15144 cikve=crkve*zlv(j)+cikve*xlv(j)
15145 crkve=crkveuk
15146 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15147 cikve=crkve*zlv(j)+cikve*xlv(j)
15148 crkve=crkveuk
15149 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15150 cikve=crkve*zlv(j)+cikve*xlv(j)
15151 crkve=crkveuk
15152 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15153 cikve=crkve*zlv(j)+cikve*xlv(j)
15154 crkve=crkveuk
15155 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15156 cikve=crkve*zlv(j)+cikve*xlv(j)
15157 crkve=crkveuk
15158 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
15159 &stracks(i)*crkve)
15160 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
15161 &stracks(i)*cikve)
15162 440 continue
15163 goto 490
15164 !--SKEW 18-POLE
15165 450 do 460 j=1,napx
15166 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
15167 &(xv(2,j)-zsiv(1,i))*tilts(i)
15168 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
15169 &(xv(2,j)-zsiv(1,i))*tiltc(i)
15170 crkve=xlv(j)
15171 cikve=zlv(j)
15172 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15173 cikve=crkve*zlv(j)+cikve*xlv(j)
15174 crkve=crkveuk
15175 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15176 cikve=crkve*zlv(j)+cikve*xlv(j)
15177 crkve=crkveuk
15178 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15179 cikve=crkve*zlv(j)+cikve*xlv(j)
15180 crkve=crkveuk
15181 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15182 cikve=crkve*zlv(j)+cikve*xlv(j)
15183 crkve=crkveuk
15184 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15185 cikve=crkve*zlv(j)+cikve*xlv(j)
15186 crkve=crkveuk
15187 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15188 cikve=crkve*zlv(j)+cikve*xlv(j)
15189 crkve=crkveuk
15190 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15191 cikve=crkve*zlv(j)+cikve*xlv(j)
15192 crkve=crkveuk
15193 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
15194 &stracks(i)*crkve)
15195 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
15196 &stracks(i)*cikve)
15197 460 continue
15198 goto 490
15199 !--SKEW 20-POLE
15200 470 do 480 j=1,napx
15201 xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+ &
15202 &(xv(2,j)-zsiv(1,i))*tilts(i)
15203 zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+ &
15204 &(xv(2,j)-zsiv(1,i))*tiltc(i)
15205 crkve=xlv(j)
15206 cikve=zlv(j)
15207 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15208 cikve=crkve*zlv(j)+cikve*xlv(j)
15209 crkve=crkveuk
15210 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15211 cikve=crkve*zlv(j)+cikve*xlv(j)
15212 crkve=crkveuk
15213 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15214 cikve=crkve*zlv(j)+cikve*xlv(j)
15215 crkve=crkveuk
15216 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15217 cikve=crkve*zlv(j)+cikve*xlv(j)
15218 crkve=crkveuk
15219 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15220 cikve=crkve*zlv(j)+cikve*xlv(j)
15221 crkve=crkveuk
15222 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15223 cikve=crkve*zlv(j)+cikve*xlv(j)
15224 crkve=crkveuk
15225 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15226 cikve=crkve*zlv(j)+cikve*xlv(j)
15227 crkve=crkveuk
15228 crkveuk=crkve*xlv(j)-cikve*zlv(j)
15229 cikve=crkve*zlv(j)+cikve*xlv(j)
15230 crkve=crkveuk
15231 yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve- &
15232 &stracks(i)*crkve)
15233 yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+ &
15234 &stracks(i)*cikve)
15235 480 continue
15236 goto 490
15237 680 continue
15238 do 690 j=1,napx
15239 if(ibbc.eq.0) then
15240 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
15241 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
15242 else
15243 crkveb(j)= &
15244 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
15245 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
15246 cikveb(j)= &
15247 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
15248 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
15249 endif
15250 rho2b(j)=crkveb(j)*crkveb(j)+cikveb(j)*cikveb(j)
15251 if(rho2b(j).le.pieni) &
15252 &goto 690
15253 tkb(j)=rho2b(j)/(two*sigman2(1,imbb(i)))
15254 if(ibbc.eq.0) then
15255 yv(1,j)=yv(1,j)+oidpsv(j)*(strack(i)*crkveb(j)/rho2b(j)* &
15256 &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))
15257 yv(2,j)=yv(2,j)+oidpsv(j)*(strack(i)*cikveb(j)/rho2b(j)* &
15258 &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))
15259 else
15260 cccc=(strack(i)*crkveb(j)/rho2b(j)* &
15261 &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))*bbcu(imbb(i),11)- &
15262 &(strack(i)*cikveb(j)/rho2b(j)* &
15263 &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
15264 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
15265 cccc=(strack(i)*crkveb(j)/rho2b(j)* &
15266 &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))*bbcu(imbb(i),12)+ &
15267 &(strack(i)*cikveb(j)/rho2b(j)* &
15268 &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
15269 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
15270 endif
15271 690 continue
15272 goto 490
15273 700 continue
15274 if(ibtyp.eq.0) then
15275 do j=1,napx
15276 r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
15277 rb(j)=sqrt(r2b(j))
15278 rkb(j)=strack(i)*pisqrt/rb(j)
15279 if(ibbc.eq.0) then
15280 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
15281 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
15282 else
15283 crkveb(j)= &
15284 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
15285 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
15286 cikveb(j)= &
15287 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
15288 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
15289 endif
15290 xrb(j)=abs(crkveb(j))/rb(j)
15291 zrb(j)=abs(cikveb(j))/rb(j)
15292 call errf(xrb(j),zrb(j),crxb(j),crzb(j))
15293 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
15294 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
15295 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
15296 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
15297 call errf(xbb(j),zbb(j),cbxb(j),cbzb(j))
15298 if(ibbc.eq.0) then
15299 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
15300 &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
15301 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
15302 &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
15303 else
15304 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
15305 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
15306 &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
15307 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
15308 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
15309 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
15310 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
15311 &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
15312 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
15313 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
15314 endif
15315 enddo
15316 else if(ibtyp.eq.1) then
15317 do j=1,napx
15318 r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
15319 rb(j)=sqrt(r2b(j))
15320 rkb(j)=strack(i)*pisqrt/rb(j)
15321 if(ibbc.eq.0) then
15322 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
15323 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
15324 else
15325 crkveb(j)= &
15326 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
15327 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
15328 cikveb(j)= &
15329 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
15330 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
15331 endif
15332 xrb(j)=abs(crkveb(j))/rb(j)
15333 zrb(j)=abs(cikveb(j))/rb(j)
15334 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
15335 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
15336 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
15337 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
15338 enddo
15339 call wzsubv(napx,xrb(1),zrb(1),crxb(1),crzb(1))
15340 call wzsubv(napx,xbb(1),zbb(1),cbxb(1),cbzb(1))
15341 do j=1,napx
15342 if(ibbc.eq.0) then
15343 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
15344 &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
15345 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
15346 &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
15347 else
15348 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
15349 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
15350 &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
15351 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
15352 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
15353 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
15354 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
15355 &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
15356 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
15357 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
15358 endif
15359 enddo
15360 endif
15361 goto 490
15362 720 continue
15363 if(ibtyp.eq.0) then
15364 do j=1,napx
15365 r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
15366 rb(j)=sqrt(r2b(j))
15367 rkb(j)=strack(i)*pisqrt/rb(j)
15368 if(ibbc.eq.0) then
15369 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
15370 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
15371 else
15372 crkveb(j)= &
15373 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
15374 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
15375 cikveb(j)= &
15376 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
15377 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
15378 endif
15379 xrb(j)=abs(crkveb(j))/rb(j)
15380 zrb(j)=abs(cikveb(j))/rb(j)
15381 call errf(zrb(j),xrb(j),crzb(j),crxb(j))
15382 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
15383 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
15384 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
15385 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
15386 call errf(zbb(j),xbb(j),cbzb(j),cbxb(j))
15387 if(ibbc.eq.0) then
15388 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
15389 &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
15390 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
15391 &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
15392 else
15393 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
15394 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
15395 &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
15396 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
15397 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
15398 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
15399 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
15400 &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
15401 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
15402 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
15403 endif
15404 enddo
15405 else if(ibtyp.eq.1) then
15406 do j=1,napx
15407 r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
15408 rb(j)=sqrt(r2b(j))
15409 rkb(j)=strack(i)*pisqrt/rb(j)
15410 if(ibbc.eq.0) then
15411 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
15412 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
15413 else
15414 crkveb(j)= &
15415 &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+ &
15416 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
15417 cikveb(j)= &
15418 &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+ &
15419 &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
15420 endif
15421 xrb(j)=abs(crkveb(j))/rb(j)
15422 zrb(j)=abs(cikveb(j))/rb(j)
15423 tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+ &
15424 &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
15425 xbb(j)=sigmanq(2,imbb(i))*xrb(j)
15426 zbb(j)=sigmanq(1,imbb(i))*zrb(j)
15427 enddo
15428 call wzsubv(napx,zrb(1),xrb(1),crzb(1),crxb(1))
15429 call wzsubv(napx,zbb(1),xbb(1),cbzb(1),cbxb(1))
15430 do j=1,napx
15431 if(ibbc.eq.0) then
15432 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
15433 &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
15434 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
15435 &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
15436 else
15437 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
15438 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
15439 &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
15440 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
15441 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
15442 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
15443 &sign(one,crkveb(j))-beamoff(4,imbb(i)))* &
15444 &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
15445 &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
15446 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
15447 endif
15448 enddo
15449 endif
15450 goto 490
15451 730 continue
15452 !--Hirata's 6D beam-beam kick
15453 do j=1,napx
15454 track6d(1,j)=(xv(1,j)+ed(ix)-clobeam(1,imbb(i)))*c1m3
15455 track6d(2,j)=(yv(1,j)/oidpsv(j)-clobeam(4,imbb(i)))*c1m3
15456 track6d(3,j)=(xv(2,j)+ek(ix)-clobeam(2,imbb(i)))*c1m3
15457 track6d(4,j)=(yv(2,j)/oidpsv(j)-clobeam(5,imbb(i)))*c1m3
15458 track6d(5,j)=(sigmv(j)-clobeam(3,imbb(i)))*c1m3
15459 track6d(6,j)=dpsv(j)-clobeam(6,imbb(i))
15460 enddo
15461 call beamint(napx,track6d,parbe,sigz,bbcu,imbb(i),ix,ibtyp, &
15462 &ibbc)
15463 do j=1,napx
15464 xv(1,j)=track6d(1,j)*c1e3+clobeam(1,imbb(i))- &
15465 &beamoff(1,imbb(i))
15466 xv(2,j)=track6d(3,j)*c1e3+clobeam(2,imbb(i))- &
15467 &beamoff(2,imbb(i))
15468 dpsv(j)=track6d(6,j)+clobeam(6,imbb(i))-beamoff(6,imbb(i))
15469 oidpsv(j)=one/(one+dpsv(j))
15470 yv(1,j)=(track6d(2,j)*c1e3+clobeam(4,imbb(i))- &
15471 &beamoff(4,imbb(i)))*oidpsv(j)
15472 yv(2,j)=(track6d(4,j)*c1e3+clobeam(5,imbb(i))- &
15473 &beamoff(5,imbb(i)))*oidpsv(j)
15474 ejfv(j)=dpsv(j)*e0f+e0f
15475 ejv(j)=sqrt(ejfv(j)*ejfv(j)+pma*pma)
15476 rvv(j)=(ejv(j)*e0f)/(e0*ejfv(j))
15477 if(ithick.eq.1) call envarsv(dpsv,oidpsv,rvv,ekv)
15478 enddo
15479 goto 490
15480 740 continue
15481 irrtr=imtr(ix)
15482 do j=1,napx
15483 sigmv(j)=sigmv(j)+cotr(irrtr,5)+rrtr(irrtr,5,1)*xv(1,j)+ &
15484 &rrtr(irrtr,5,2)*yv(1,j)+rrtr(irrtr,5,3)*xv(2,j)+ &
15485 &rrtr(irrtr,5,4)*yv(2,j)
15486 pux=xv(1,j)
15487 dpsv3(j)=dpsv(j)*c1e3
15488 xv(1,j)=cotr(irrtr,1)+rrtr(irrtr,1,1)*pux+ &
15489 &rrtr(irrtr,1,2)*yv(1,j)+idz(1)*dpsv3(j)*rrtr(irrtr,1,6)
15490 yv(1,j)=cotr(irrtr,2)+rrtr(irrtr,2,1)*pux+ &
15491 &rrtr(irrtr,2,2)*yv(1,j)+idz(1)*dpsv3(j)*rrtr(irrtr,2,6)
15492 pux=xv(2,j)
15493 xv(2,j)=cotr(irrtr,3)+rrtr(irrtr,3,3)*pux+ &
15494 &rrtr(irrtr,3,4)*yv(2,j)+idz(2)*dpsv3(j)*rrtr(irrtr,3,6)
15495 yv(2,j)=cotr(irrtr,4)+rrtr(irrtr,4,3)*pux+ &
15496 &rrtr(irrtr,4,4)*yv(2,j)+idz(2)*dpsv3(j)*rrtr(irrtr,4,6)
15497 enddo
15498
15499 !----------------------------------------------------------------------
15500
15501 ! Wire.
15502
15503 goto 490
15504 745 continue
15505 xory=1
15506 nfree=nturn1(ix)
15507 if(n.gt.nfree) then
15508 nac=n-nfree
15509 pi=4d0*atan(1d0)
15510 !---------ACdipAmp input in Tesla*meter converted to KeV/c
15511 !---------ejfv(j) should be in MeV/c --> ACdipAmp/ejfv(j) is in mrad
15512 acdipamp=ed(ix)*clight*1.0d-3
15513 !---------Qd input in tune units
15514 qd=ek(ix)
15515 !---------ACphase input in radians
15516 acphase=acdipph(ix)
15517 nramp1=nturn2(ix)
15518 nplato=nturn3(ix)
15519 nramp2=nturn4(ix)
15520 do j=1,napx
15521 if (xory.eq.1) then
15522 acdipamp2=acdipamp*tilts(i)
15523 acdipamp1=acdipamp*tiltc(i)
15524 else
15525 acdipamp2=acdipamp*tiltc(i)
15526 acdipamp1=-acdipamp*tilts(i)
15527 endif
15528 if(nramp1.gt.nac) then
15529 yv(1,j)=yv(1,j)+acdipamp1* &
15530 &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
15531 yv(2,j)=yv(2,j)+acdipamp2* &
15532 &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
15533 endif
15534 if(nac.ge.nramp1.and.(nramp1+nplato).gt.nac) then
15535 yv(1,j)=yv(1,j)+acdipamp1* &
15536 &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
15537 yv(2,j)=yv(2,j)+acdipamp2* &
15538 &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
15539 endif
15540 if(nac.ge.(nramp1+nplato).and.(nramp2+nramp1+nplato).gt. &
15541 &nac)then
15542 yv(1,j)=yv(1,j)+acdipamp1*sin(2d0*pi*qd*nac+acphase)* &
15543 &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
15544 yv(2,j)=yv(2,j)+acdipamp2*sin(2d0*pi*qd*nac+acphase)* &
15545 &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
15546 endif
15547 enddo
15548 endif
15549 goto 490
15550 746 continue
15551 xory=2
15552 nfree=nturn1(ix)
15553 if(n.gt.nfree) then
15554 nac=n-nfree
15555 pi=4d0*atan(1d0)
15556 !---------ACdipAmp input in Tesla*meter converted to KeV/c
15557 !---------ejfv(j) should be in MeV/c --> ACdipAmp/ejfv(j) is in mrad
15558 acdipamp=ed(ix)*clight*1.0d-3
15559 !---------Qd input in tune units
15560 qd=ek(ix)
15561 !---------ACphase input in radians
15562 acphase=acdipph(ix)
15563 nramp1=nturn2(ix)
15564 nplato=nturn3(ix)
15565 nramp2=nturn4(ix)
15566 do j=1,napx
15567 if (xory.eq.1) then
15568 acdipamp2=acdipamp*tilts(i)
15569 acdipamp1=acdipamp*tiltc(i)
15570 else
15571 acdipamp2=acdipamp*tiltc(i)
15572 acdipamp1=-acdipamp*tilts(i)
15573 endif
15574 if(nramp1.gt.nac) then
15575 yv(1,j)=yv(1,j)+acdipamp1* &
15576 &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
15577 yv(2,j)=yv(2,j)+acdipamp2* &
15578 &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
15579 endif
15580 if(nac.ge.nramp1.and.(nramp1+nplato).gt.nac) then
15581 yv(1,j)=yv(1,j)+acdipamp1* &
15582 &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
15583 yv(2,j)=yv(2,j)+acdipamp2* &
15584 &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
15585 endif
15586 if(nac.ge.(nramp1+nplato).and.(nramp2+nramp1+nplato).gt. &
15587 &nac)then
15588 yv(1,j)=yv(1,j)+acdipamp1*sin(2d0*pi*qd*nac+acphase)* &
15589 &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
15590 yv(2,j)=yv(2,j)+acdipamp2*sin(2d0*pi*qd*nac+acphase)* &
15591 &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
15592 endif
15593 enddo
15594 endif
15595 goto 490
15596
15597 !----------------------------
15598
15599 ! Wire.
15600
15601 748 continue
15602 ! magnetic rigidity
15603 chi = sqrt(e0*e0-pmap*pmap)*c1e6/clight
15604
15605 ix = ixcav
15606 tx = xrms(ix)
15607 ty = zrms(ix)
15608 dx = xpl(ix)
15609 dy = zpl(ix)
15610 embl = ek(ix)
15611 l = wirel(ix)
15612 cur = ed(ix)
15613
15614 leff = embl/cos(tx)/cos(ty)
15615 rx = dx *cos(tx)-embl*sin(tx)/2
15616 lin= dx *sin(tx)+embl*cos(tx)/2
15617 ry = dy *cos(ty)-lin *sin(ty)
15618 lin= lin*cos(ty)+dy *sin(ty)
15619
15620 do 750 j=1, napx
15621
15622 xv(1,j) = xv(1,j) * c1m3
15623 xv(2,j) = xv(2,j) * c1m3
15624 yv(1,j) = yv(1,j) * c1m3
15625 yv(2,j) = yv(2,j) * c1m3
15626
15627 ! print *, 'Start: ',j,xv(1,j),xv(2,j),yv(1,j),
15628 ! &yv(2,j)
15629
15630 ! call drift(-embl/2)
15631
15632 xv(1,j) = xv(1,j) - embl/2*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
15633 &yv(2,j)**2)
15634 xv(2,j) = xv(2,j) - embl/2*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
15635 &yv(2,j)**2)
15636
15637 ! call tilt(tx,ty)
15638
15639 xv(2,j) = xv(2,j)-xv(1,j)*sin(tx)*yv(2,j)/sqrt((1+dpsv(j))**2- &
15640 &yv(2,j)**2)/cos(atan(yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
15641 &yv(2,j)**2))-tx)
15642 xv(1,j) = xv(1,j)*(cos(tx)-sin(tx)*tan(atan(yv(1,j)/ &
15643 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-tx))
15644 yv(1,j) = sqrt((1+dpsv(j))**2-yv(2,j)**2)*sin(atan(yv(1,j)/ &
15645 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-tx)
15646
15647 xv(1,j) = xv(1,j)-xv(2,j)*sin(ty)*yv(1,j)/sqrt((1+dpsv(j))**2- &
15648 &yv(1,j)**2)/cos(atan(yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
15649 &yv(2,j)**2))-ty)
15650 xv(2,j) = xv(2,j)*(cos(ty)-sin(ty)*tan(atan(yv(2,j)/ &
15651 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-ty))
15652 yv(2,j) = sqrt((1+dpsv(j))**2-yv(1,j)**2)*sin(atan(yv(2,j)/ &
15653 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-ty)
15654
15655 ! call drift(lin)
15656
15657 xv(1,j) = xv(1,j) + lin*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
15658 &yv(2,j)**2)
15659 xv(2,j) = xv(2,j) + lin*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
15660 &yv(2,j)**2)
15661
15662 ! call kick(l,cur,lin,rx,ry,chi)
15663
15664 xi = xv(1,j)-rx
15665 yi = xv(2,j)-ry
15666 yv(1,j) = yv(1,j)-1.0d-7*cur/chi*xi/(xi**2+yi**2)* &
15667 &(sqrt((lin+l)**2+xi**2+yi**2)-sqrt((lin-l)**2+ &
15668 &xi**2+yi**2))
15669 !GRD FOR CONSISTENSY
15670 ! yv(2,j) = yv(2,j)-1e-7*cur/chi*yi/(xi**2+yi**2)* &
15671 yv(2,j) = yv(2,j)-1.0d-7*cur/chi*yi/(xi**2+yi**2)* &
15672 &(sqrt((lin+l)**2+xi**2+yi**2)-sqrt((lin-l)**2+ &
15673 &xi**2+yi**2))
15674
15675 ! call drift(leff-lin)
15676
15677 xv(1,j) = xv(1,j) + (leff-lin)*yv(1,j)/sqrt((1+dpsv(j))**2- &
15678 &yv(1,j)**2-yv(2,j)**2)
15679 xv(2,j) = xv(2,j) + (leff-lin)*yv(2,j)/sqrt((1+dpsv(j))**2- &
15680 &yv(1,j)**2-yv(2,j)**2)
15681
15682 ! call invtilt(tx,ty)
15683
15684 xv(1,j) = xv(1,j)-xv(2,j)*sin(-ty)*yv(1,j)/sqrt((1+dpsv(j))**2- &
15685 &yv(1,j)**2)/cos(atan(yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
15686 &yv(2,j)**2))+ty)
15687 xv(2,j) = xv(2,j)*(cos(-ty)-sin(-ty)*tan(atan(yv(2,j)/ &
15688 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+ty))
15689 yv(2,j) = sqrt((1+dpsv(j))**2-yv(1,j)**2)*sin(atan(yv(2,j)/ &
15690 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+ty)
15691
15692 xv(2,j) = xv(2,j)-xv(1,j)*sin(-tx)*yv(2,j)/sqrt((1+dpsv(j))**2- &
15693 &yv(2,j)**2)/cos(atan(yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2- &
15694 &yv(2,j)**2))+tx)
15695 xv(1,j) = xv(1,j)*(cos(-tx)-sin(-tx)*tan(atan(yv(1,j)/ &
15696 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+tx))
15697 yv(1,j) = sqrt((1+dpsv(j))**2-yv(2,j)**2)*sin(atan(yv(1,j)/ &
15698 &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+tx)
15699
15700 ! call shift(-embl*tan(tx),-embl*tan(ty)/cos(tx))
15701
15702 xv(1,j) = xv(1,j) + embl*tan(tx)
15703 xv(2,j) = xv(2,j) + embl*tan(ty)/cos(tx)
15704
15705 ! call drift(-embl/2)
15706
15707 xv(1,j) = xv(1,j) - embl/2*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
15708 &yv(2,j)**2)
15709 xv(2,j) = xv(2,j) - embl/2*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
15710 &yv(2,j)**2)
15711
15712 xv(1,j) = xv(1,j) * c1e3
15713 xv(2,j) = xv(2,j) * c1e3
15714 yv(1,j) = yv(1,j) * c1e3
15715 yv(2,j) = yv(2,j) * c1e3
15716
15717 ! print *, 'End: ',j,xv(1,j),xv(2,j),yv(1,j),
15718 ! &yv(2,j)
15719
15720 !-----------------------------------------------------------------------
15721
15722 750 continue
15723 goto 490
15724
15725 !----------------------------
15726
15727 490 continue
15728 llost=.false.
15729 do j=1,napx
15730 llost=llost.or. &
15731 &abs(xv(1,j)).gt.aper(1).or.abs(xv(2,j)).gt.aper(2)
15732 enddo
15733 if (llost) then
15734 kpz=abs(kp(ix))
15735 if(kpz.eq.2) then
15736 call lostpar3(i,ix,nthinerr)
15737 if(nthinerr.ne.0) return
15738 elseif(kpz.eq.3) then
15739 call lostpar4(i,ix,nthinerr)
15740 if(nthinerr.ne.0) return
15741 else
15742 call lostpar2(i,ix,nthinerr)
15743 if(nthinerr.ne.0) return
15744 endif
15745 endif
15746 500 continue
15747 call lostpart(nthinerr)
15748 if(nthinerr.ne.0) return
15749 if(ntwin.ne.2) call dist1
15750 if(mod(n,nwr(4)).eq.0) call write6(n)
15751 510 continue
15752 return
15753 end
15754 subroutine synuthck
15755 !-----------------------------------------------------------------------
15756 !
15757 ! TRACK THICK LENS PART
15758 !
15759 !
15760 ! F. SCHMIDT
15761 !-----------------------------------------------------------------------
15762 ! 3 February 1999
15763 !-----------------------------------------------------------------------
15764 implicit none
15765 integer ih1,ih2,j,kz1,l
15766 double precision fokm
15767 integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1, &
15768 &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran, &
15769 &nrco,ntr,nzfz
15770 parameter(npart = 64,nmac = 1)
15771 parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000, &
15772 &nzfz = 300000,mmul = 11)
15773 parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5, &
15774 &nema = 15)
15775 parameter(mcor = 10,mcop = mcor+6, mbea = 15)
15776 parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
15777 parameter(nmon1 = 600,ncor1 = 600)
15778 parameter(ntr = 20,nbb = 160)
15779 double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3, &
15780 &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21, &
15781 &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
15782 &one,pieni,pmae,pmap,three,two,zero
15783 parameter(pieni = 1d-38)
15784 parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
15785 parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
15786 parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
15787 parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
15788 parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 = &
15789 &1.0d16)
15790 parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
15791 parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
15792 parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
15793 parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
15794 parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
15795 parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
15796 parameter(pmap = 938.271998d0,pmae = .510998902d0)
15797 parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
15798 integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo, &
15799 &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor, &
15800 &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb, &
15801 &imc,imtr,iorg,iout, &
15802 &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires, &
15803 &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw, &
15804 &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox, &
15805 &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo, &
15806 &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx, &
15807 &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr, &
15808 &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew, &
15809 &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr, &
15810 &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
15811 double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu, &
15812 &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
15813 &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft, &
15814 &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
15815 &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign, &
15816 &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum, &
15817 &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
15818 &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph, &
15819 &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
15820 &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel, &
15821 &acdipph
15822 real hmal
15823 character*16 bez,bezb,bezr,erbez,bezl
15824 character*80 toptit,sixtit,commen
15825 common/erro/ierro,erbez
15826 common/kons/pi,pi2,pisqrt,rad
15827 common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
15828 common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
15829 common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
15830 common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
15831 common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
15832 common/syos2/rvf(mpa)
15833 common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
15834 &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
15835 common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3), &
15836 &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen, &
15837 &iicav,itionc(nele),ition,idp,ncy,ixcav
15838 common/corcom/dpscor,sigcor,icode,idam,its6d
15839 common/multi/bk0(nele,mmul),ak0(nele,mmul), &
15840 &bka(nele,mmul),aka(nele,mmul)
15841 common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
15842 common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
15843 common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz), &
15844 &tilts(nblz),mout2,icext(nblz),icextal(nblz)
15845 common/beo /aper(2),di0(2),dip0(2),ta(6,6)
15846 common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
15847 &iout
15848 common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
15849 common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint, &
15850 &ntco,eui,euii,nlin,bezl(nele)
15851 common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2), &
15852 &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr, &
15853 &ncororb(nele)
15854 common/apert/apx(nele),apz(nele),ape(3,nele)
15855 common/clos/sigma0(2),iclo,ncorru,ncorrep
15856 common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20), &
15857 &ratioe(nele),iratioe(nele),icoe
15858 common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
15859 common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
15860 common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
15861 common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
15862 common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2, &
15863 &nstart,nstop,iskip,iconv,imad
15864 common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
15865 common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
15866 common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
15867 common/ripp2/nrturn
15868 common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
15869 common/pawc/hmal(nplo)
15870 common/tit/sixtit,commen,ithick
15871 common/co6d/clo6(3),clop6(3)
15872 common/dkic/dki(nele,3)
15873 common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb), &
15874 &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart), &
15875 &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar, &
15876 &nbeam,ibbc,ibeco,ibtyp,lhc
15877 common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
15878 common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
15879 common/wireco/ wirel(nele)
15880 common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele), &
15881 &nturn3(nele), nturn4(nele)
15882 integer idz,itra
15883 double precision al,as,chi0,chid,dp1,dps,exz,sigm
15884 common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa), &
15885 &dps(mpa),idz(2)
15886 common/anf/chi0,chid,exz(2,6),dp1,itra
15887 integer ichrom,is
15888 double precision alf0,amp,bet0,clo,clop,cro,x,y
15889 common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
15890 common/chrom/cro(2),is(2),ichrom
15891 integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
15892 &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
15893 double precision dpmax,preda,weig1,weig2
15894 character*16 coel
15895 common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
15896 common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
15897 common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
15898 &coel(10)
15899 double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
15900 &zsi
15901 real tlim,time0,time1
15902 common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz), &
15903 &aai(nblz,mmul),bbi(nblz,mmul)
15904 common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
15905 common/damp/damp,ampt
15906 common/ttime/tlim,time0,time1
15907 double precision tasm
15908 common/tasm/tasm(6,6)
15909 integer iv,ixv,nlostp,nms,numxv
15910 double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
15911 &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
15912 &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl, &
15913 &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
15914 &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv, &
15915 &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas, &
15916 &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
15917 &zsiv,zsv
15918 logical pstop
15919 common/main1/ &
15920 &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz), &
15921 &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz), &
15922 &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2), &
15923 &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart), &
15924 &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart), &
15925 &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart), &
15926 &xlv(npart),zlv(npart),pstop(npart),rvv(npart), &
15927 &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
15928 common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart), &
15929 &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart), &
15930 &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart), &
15931 &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart), &
15932 &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart), &
15933 &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
15934 &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
15935 &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart), &
15936 &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
15937 common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo), &
15938 &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart), &
15939 &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6), &
15940 &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
15941 integer numx
15942 double precision e0f
15943 common/main4/ e0f,numx
15944 integer ktrack,nwri
15945 double precision dpsv1,strack,strackc,stracks
15946 common/track/ ktrack(nblz),strack(nblz),strackc(nblz), &
15947 &stracks(nblz),dpsv1(npart),nwri
15948 save
15949 !--------------------------------------- SUBROUTINE 'ENVARS' IN-LINE
15950 do 10 j=1,napx
15951 dpd(j)=one+dpsv(j)
15952 dpsq(j)=sqrt(dpd(j))
15953 !
15954 10 continue
15955 do 160 l=1,il
15956 if(abs(el(l)).le.pieni) goto 160
15957 kz1=kz(l)+1
15958 goto(20,40,80,60,40,60,100,100,140),kz1
15959 goto 160
15960 !-----------------------------------------------------------------------
15961 ! DRIFTLENGTH
15962 !-----------------------------------------------------------------------
15963 20 do 30 j=1,napx
15964 as(6,1,j,l)=-rvv(j)*el(l)/c2e3
15965 as(6,2,j,l)=as(6,1,j,l)
15966 as(1,1,j,l)=el(l)*(one-rvv(j))*c1e3
15967 30 continue
15968 goto 160
15969 !-----------------------------------------------------------------------
15970 ! RECTANGULAR MAGNET
15971 ! HORIZONTAL
15972 !-----------------------------------------------------------------------
15973 40 fokm=el(l)*ed(l)
15974 if(abs(fokm).le.pieni) goto 20
15975 if(kz1.eq.2) then
15976 ih1=1
15977 ih2=2
15978 else
15979 ! RECTANGULAR MAGNET VERTICAL
15980 ih1=2
15981 ih2=1
15982 endif
15983 do 50 j=1,napx
15984 fok(j)=fokm/dpsq(j)
15985 rho(j)=(one/ed(l))*dpsq(j)
15986 fok1(j)=(tan(fok(j)*half))/rho(j)
15987 si(j)=sin(fok(j))
15988 co(j)=cos(fok(j))
15989 al(2,ih1,j,l)=rho(j)*si(j)
15990 al(5,ih1,j,l)=-dpsv(j)*(rho(j)*(one-co(j))/dpsq(j))*c1e3
15991 al(6,ih1,j,l)=-dpsv(j)*(two*tan(fok(j)*half)/dpsq(j))*c1e3
15992 sm1(j)=cos(fok(j))
15993 sm2(j)=sin(fok(j))*rho(j)
15994 sm3(j)=-sin(fok(j))/rho(j)
15995 sm12(j)=el(l)-sm1(j)*sm2(j)
15996 sm23(j)=sm2(j)*sm3(j)
15997 as3(j)=-rvv(j)*(dpsv(j)*rho(j)/(two*dpsq(j))*sm23(j)- rho(j) &
15998 &*dpsq(j)*(one-sm1(j)))
15999 as4(j)=-rvv(j)*sm23(j)/c2e3
16000 as6(j)=-rvv(j)*(el(l)+sm1(j)*sm2(j))/c4e3
16001 as(1,ih1,j,l)=(-rvv(j)*(dpsv(j)*dpsv(j)/(four*dpd(j))*sm12(j)+&
16002 &dpsv(j)*(el(l)-sm2(j)))+el(l)*(one-rvv(j)))*c1e3
16003 as(2,ih1,j,l)=-rvv(j)*(dpsv(j)/(two*rho(j)*dpsq(j))*sm12(j)- &
16004 &sm2(j)*dpsq(j)/rho(j))+fok1(j)*as3(j)
16005 as(3,ih1,j,l)=as3(j)
16006 as(4,ih1,j,l)=as4(j)+two*as6(j)*fok1(j)
16007 as(5,ih1,j,l)=-rvv(j)*sm12(j)/(c4e3*rho(j)*rho(j))+ as6(j) &
16008 &*fok1(j)*fok1(j)+fok1(j)*as4(j)
16009 as(6,ih1,j,l)=as6(j)
16010 !--VERTIKAL
16011 g(j)=tan(fok(j)*half)/rho(j)
16012 gl(j)=el(l)*g(j)
16013 al(1,ih2,j,l)=one-gl(j)
16014 al(3,ih2,j,l)=-g(j)*(two-gl(j))
16015 al(4,ih2,j,l)=al(1,ih2,j,l)
16016 as6(j)=-rvv(j)*al(2,ih2,j,l)/c2e3
16017 as(4,ih2,j,l)=-two*as6(j)*fok1(j)
16018 as(5,ih2,j,l)=as6(j)*fok1(j)*fok1(j)
16019 as(6,ih2,j,l)=as6(j)
16020 50 continue
16021 goto 160
16022 !-----------------------------------------------------------------------
16023 ! SEKTORMAGNET
16024 ! HORIZONTAL
16025 !-----------------------------------------------------------------------
16026 60 fokm=el(l)*ed(l)
16027 if(abs(fokm).le.pieni) goto 20
16028 if(kz1.eq.4) then
16029 ih1=1
16030 ih2=2
16031 else
16032 ! SECTOR MAGNET VERTICAL
16033 ih1=2
16034 ih2=1
16035 endif
16036 do 70 j=1,napx
16037 fok(j)=fokm/dpsq(j)
16038 rho(j)=(one/ed(l))*dpsq(j)
16039 si(j)=sin(fok(j))
16040 co(j)=cos(fok(j))
16041 rhoc(j)=rho(j)*(one-co(j))/dpsq(j)
16042 siq(j)=si(j)/dpsq(j)
16043 al(1,ih1,j,l)=co(j)
16044 al(2,ih1,j,l)=rho(j)*si(j)
16045 al(3,ih1,j,l)=-si(j)/rho(j)
16046 al(4,ih1,j,l)=co(j)
16047 al(5,ih1,j,l)=-dpsv(j)*rhoc(j)*c1e3
16048 al(6,ih1,j,l)=-dpsv(j)*siq(j)*c1e3
16049 sm12(j)=el(l)-al(1,ih1,j,l)*al(2,ih1,j,l)
16050 sm23(j)=al(2,ih1,j,l)*al(3,ih1,j,l)
16051 as(1,ih1,j,l)=(-rvv(j)*(dpsv(j)*dpsv(j)/(four*dpd(j))*sm12(j) &
16052 &+dpsv(j)*(el(l)-al(2,ih1,j,l)))+el(l)*(one-rvv(j)))*c1e3
16053 as(2,ih1,j,l)=-rvv(j)*(dpsv(j)/(two*rho(j)*dpsq(j))*sm12(j)- &
16054 &dpd(j)*siq(j))
16055 as(3,ih1,j,l)=-rvv(j)*(dpsv(j)*rho(j)/(two*dpsq(j))*sm23(j)- &
16056 &dpd(j)*rhoc(j))
16057 as(4,ih1,j,l)=-rvv(j)*sm23(j)/c2e3
16058 as(5,ih1,j,l)=-rvv(j)*sm12(j)/(c4e3*rho(j)*rho(j))
16059 as(6,ih1,j,l)=-rvv(j)*(el(l)+al(1,ih1,j,l)*al(2,ih1,j,l))/c4e3
16060 !--VERTIKAL
16061 as(6,ih2,j,l)=-rvv(j)*al(2,ih2,j,l)/c2e3
16062 70 continue
16063 goto 160
16064 !-----------------------------------------------------------------------
16065 ! QUADRUPOLE
16066 ! FOCUSSING
16067 !-----------------------------------------------------------------------
16068 80 do 90 j=1,napx
16069 fok(j)=ekv(j,l)*oidpsv(j)
16070 aek(j)=abs(fok(j))
16071 hi(j)=sqrt(aek(j))
16072 fi(j)=el(l)*hi(j)
16073 if(fok(j).le.zero) then
16074 al(1,1,j,l)=cos(fi(j))
16075 hi1(j)=sin(fi(j))
16076 if(abs(hi(j)).le.pieni) then
16077 al(2,1,j,l)=el(l)
16078 else
16079 al(2,1,j,l)=hi1(j)/hi(j)
16080 endif
16081 al(3,1,j,l)=-hi1(j)*hi(j)
16082 al(4,1,j,l)=al(1,1,j,l)
16083 as(1,1,j,l)=el(l)*(one-rvv(j))*c1e3
16084 as(4,1,j,l)=-rvv(j)*al(2,1,j,l)*al(3,1,j,l)/c2e3
16085 as(5,1,j,l)=-rvv(j)*(el(l)-al(1,1,j,l)*al(2,1,j,l))* aek(j) &
16086 &/c4e3
16087 as(6,1,j,l)=-rvv(j)*(el(l)+al(1,1,j,l)*al(2,1,j,l))/c4e3
16088 !--DEFOCUSSING
16089 hp(j)=exp(fi(j))
16090 hm(j)=one/hp(j)
16091 hc(j)=(hp(j)+hm(j))*half
16092 hs(j)=(hp(j)-hm(j))*half
16093 al(1,2,j,l)=hc(j)
16094 if(abs(hi(j)).le.pieni) then
16095 al(2,2,j,l)=el(l)
16096 else
16097 al(2,2,j,l)=hs(j)/hi(j)
16098 endif
16099 al(3,2,j,l)=hs(j)*hi(j)
16100 al(4,2,j,l)=hc(j)
16101 as(4,2,j,l)=-rvv(j)*al(2,2,j,l)*al(3,2,j,l)/c2e3
16102 as(5,2,j,l)=+rvv(j)*(el(l)-al(1,2,j,l)*al(2,2,j,l))* aek(j) &
16103 &/c4e3
16104 as(6,2,j,l)=-rvv(j)*(el(l)+al(1,2,j,l)*al(2,2,j,l))/c4e3
16105 else
16106 al(1,2,j,l)=cos(fi(j))
16107 hi1(j)=sin(fi(j))
16108 if(abs(hi(j)).le.pieni) then
16109 al(2,2,j,l)=el(l)
16110 else
16111 al(2,2,j,l)=hi1(j)/hi(j)
16112 endif
16113 al(3,2,j,l)=-hi1(j)*hi(j)
16114 al(4,2,j,l)=al(1,2,j,l)
16115 as(1,2,j,l)=el(l)*(one-rvv(j))*c1e3
16116 as(4,2,j,l)=-rvv(j)*al(2,2,j,l)*al(3,2,j,l)/c2e3
16117 as(5,2,j,l)=-rvv(j)*(el(l)-al(1,2,j,l)*al(2,2,j,l))* aek(j) &
16118 &/c4e3
16119 as(6,2,j,l)=-rvv(j)*(el(l)+al(1,2,j,l)*al(2,2,j,l))/c4e3
16120 !--DEFOCUSSING
16121 hp(j)=exp(fi(j))
16122 hm(j)=one/hp(j)
16123 hc(j)=(hp(j)+hm(j))*half
16124 hs(j)=(hp(j)-hm(j))*half
16125 al(1,1,j,l)=hc(j)
16126 if(abs(hi(j)).le.pieni) then
16127 al(2,1,j,l)=el(l)
16128 else
16129 al(2,1,j,l)=hs(j)/hi(j)
16130 endif
16131 al(3,1,j,l)=hs(j)*hi(j)
16132 al(4,1,j,l)=hc(j)
16133 as(4,1,j,l)=-rvv(j)*al(2,1,j,l)*al(3,1,j,l)/c2e3
16134 as(5,1,j,l)=+rvv(j)*(el(l)-al(1,1,j,l)*al(2,1,j,l))* aek(j) &
16135 &/c4e3
16136 as(6,1,j,l)=-rvv(j)*(el(l)+al(1,1,j,l)*al(2,1,j,l))/c4e3
16137 endif
16138 90 continue
16139 goto 160
16140 !-----------------------------------------------------------------------
16141 ! COMBINED FUNCTION MAGNET HORIZONTAL
16142 ! FOCUSSING
16143 !-----------------------------------------------------------------------
16144 100 if(kz1.eq.7) then
16145 do 110 j=1,napx
16146 fokqv(j)=ekv(j,l)
16147 110 continue
16148 ih1=1
16149 ih2=2
16150 else
16151 ! COMBINED FUNCTION MAGNET VERTICAL
16152 do 120 j=1,napx
16153 fokqv(j)=-ekv(j,l)
16154 120 continue
16155 ih1=2
16156 ih2=1
16157 endif
16158 do 130 j=1,napx
16159 wf(j)=ed(l)/dpsq(j)
16160 fok(j)=fokqv(j)/dpd(j)-wf(j)*wf(j)
16161 afok(j)=abs(fok(j))
16162 hi(j)=sqrt(afok(j))
16163 fi(j)=hi(j)*el(l)
16164 if(afok(j).le.pieni) then
16165 as(6,1,j,l)=-rvv(j)*el(l)/c2e3
16166 as(6,2,j,l)=as(6,1,j,l)
16167 as(1,1,j,l)=el(l)*(one-rvv(j))*c1e3
16168 endif
16169 if(fok(j).lt.-pieni) then
16170 si(j)=sin(fi(j))
16171 co(j)=cos(fi(j))
16172 wfa(j)=wf(j)/afok(j)*(one-co(j))/dpsq(j)
16173 wfhi(j)=wf(j)/hi(j)*si(j)/dpsq(j)
16174 al(1,ih1,j,l)=co(j)
16175 al(2,ih1,j,l)=si(j)/hi(j)
16176 al(3,ih1,j,l)=-si(j)*hi(j)
16177 al(4,ih1,j,l)=co(j)
16178 al(5,ih1,j,l)=-wfa(j)*dpsv(j)*c1e3
16179 al(6,ih1,j,l)=-wfhi(j)*dpsv(j)*c1e3
16180 sm12(j)=el(l)-al(1,ih1,j,l)*al(2,ih1,j,l)
16181 sm23(j)=al(2,ih1,j,l)*al(3,ih1,j,l)
16182 as(1,ih1,j,l)=(-rvv(j)*(dpsv(j)*dpsv(j)/(four*dpd(j))*sm12 &
16183 &(j)+ dpsv(j)*(el(l)-al(2,ih1,j,l)))/afok(j)*wf(j)*wf(j)+el &
16184 &(l)* (one-rvv(j)))*c1e3
16185 as(2,ih1,j,l)=-rvv(j)*(dpsv(j)*wf(j)/(two*dpsq(j))*sm12(j)- &
16186 &dpd(j)*wfhi(j))
16187 as(3,ih1,j,l)=-rvv(j)*(dpsv(j)*half/afok(j)/dpd(j)* ed(l) &
16188 &*sm23(j)-dpd(j)*wfa(j))
16189 as(4,ih1,j,l)=-rvv(j)*sm23(j)/c2e3
16190 as(5,ih1,j,l)=-rvv(j)*sm12(j)*afok(j)/c4e3
16191 as(6,ih1,j,l)=-rvv(j)*(el(l)+al(1,ih1,j,l)*al(2,ih1,j,l)) &
16192 &/c4e3
16193 aek(j)=abs(ekv(j,l)/dpd(j))
16194 hi(j)=sqrt(aek(j))
16195 fi(j)=hi(j)*el(l)
16196 hp(j)=exp(fi(j))
16197 hm(j)=one/hp(j)
16198 hc(j)=(hp(j)+hm(j))*half
16199 hs(j)=(hp(j)-hm(j))*half
16200 al(1,ih2,j,l)=hc(j)
16201 if(abs(hi(j)).gt.pieni) al(2,ih2,j,l)=hs(j)/hi(j)
16202 al(3,ih2,j,l)=hs(j)*hi(j)
16203 al(4,ih2,j,l)=hc(j)
16204 as(4,ih2,j,l)=-rvv(j)*al(2,ih2,j,l)*al(3,ih2,j,l)/c2e3
16205 as(5,ih2,j,l)=+rvv(j)*(el(l)-al(1,ih2,j,l)*al(2,ih2,j,l))* &
16206 &aek(j)/c4e3
16207 as(6,ih2,j,l)=-rvv(j)*(el(l)+al(1,ih2,j,l)*al(2,ih2,j,l)) &
16208 &/c4e3
16209 endif
16210 !--DEFOCUSSING
16211 if(fok(j).gt.pieni) then
16212 hp(j)=exp(fi(j))
16213 hm(j)=one/hp(j)
16214 hc(j)=(hp(j)+hm(j))*half
16215 hs(j)=(hp(j)-hm(j))*half
16216 al(1,ih1,j,l)=hc(j)
16217 al(2,ih1,j,l)=hs(j)/hi(j)
16218 al(3,ih1,j,l)=hs(j)*hi(j)
16219 al(4,ih1,j,l)=hc(j)
16220 wfa(j)=wf(j)/afok(j)*(one-hc(j))/dpsq(j)
16221 wfhi(j)=wf(j)/hi(j)*hs(j)/dpsq(j)
16222 al(5,ih1,j,l)= wfa(j)*dpsv(j)*c1e3
16223 al(6,ih1,j,l)=-wfhi(j)*dpsv(j)*c1e3
16224 sm12(j)=el(l)-al(1,ih1,j,l)*al(2,ih1,j,l)
16225 sm23(j)=al(2,ih1,j,l)*al(3,ih1,j,l)
16226 as(1,ih1,j,l)=(rvv(j)*(dpsv(j)*dpsv(j)/(four*dpd(j))*sm12(j)&
16227 &+dpsv(j)*(el(l)-al(2,ih1,j,l)))/afok(j)*wf(j)*wf(j)+el(l)* &
16228 &(one-rvv(j)))*c1e3
16229 as(2,ih1,j,l)=-rvv(j)*(dpsv(j)*wf(j)/(two*dpsq(j))*sm12(j)- &
16230 &dpd(j)*wfhi(j))
16231 as(3,ih1,j,l)=rvv(j)*(dpsv(j)*half/afok(j)/dpd(j)* ed(l) &
16232 &*sm23(j)-dpd(j)*wfa(j))
16233 as(4,ih1,j,l)=-rvv(j)*sm23(j)/c2e3
16234 as(5,ih1,j,l)=+rvv(j)*sm12(j)*afok(j)/c4e3
16235 as(6,ih1,j,l)=-rvv(j)*(el(l)+al(1,ih1,j,l)*al(2,ih1,j,l)) &
16236 &/c4e3
16237 aek(j)=abs(ekv(j,l)/dpd(j))
16238 hi(j)=sqrt(aek(j))
16239 fi(j)=hi(j)*el(l)
16240 si(j)=sin(fi(j))
16241 co(j)=cos(fi(j))
16242 al(1,ih2,j,l)=co(j)
16243 al(2,ih2,j,l)=si(j)/hi(j)
16244 al(3,ih2,j,l)=-si(j)*hi(j)
16245 al(4,ih2,j,l)=co(j)
16246 as(4,ih2,j,l)=-rvv(j)*al(2,ih2,j,l)*al(3,ih2,j,l)/c2e3
16247 as(5,ih2,j,l)=-rvv(j)*(el(l)-al(1,ih2,j,l)*al(2,ih2,j,l))* &
16248 &aek(j)/c4e3
16249 as(6,ih2,j,l)=-rvv(j)*(el(l)+al(1,ih2,j,l)*al(2,ih2,j,l)) &
16250 &/c4e3
16251 endif
16252 130 continue
16253 goto 160
16254 !-----------------------------------------------------------------------
16255 ! EDGE FOCUSSING
16256 !-----------------------------------------------------------------------
16257 140 do 150 j=1,napx
16258 rhoi(j)=ed(l)/dpsq(j)
16259 fok(j)=rhoi(j)*tan(el(l)*rhoi(j)*half)
16260 al(3,1,j,l)=fok(j)
16261 al(3,2,j,l)=-fok(j)
16262 150 continue
16263 160 continue
16264 !--------------------------------------- END OF 'ENVARS' (2)
16265 return
16266 end
16267 subroutine collimate2(name_coll,
16268 & c_material, c_length, c_rotation, &
16269 &c_aperture, c_offset, c_tilt,x_in, xp_in, y_in,yp_in,p_in, s_in, &
16270 &np, enom, lhit,part_abs, impact, indiv, lint, onesided, name, &
16271 &flagsec, j_slices)
16272 !MAY2005
16273 !-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----
16274 !---- -----
16275 !----- NEW ROUTINES PROVIDED FOR THE COLLIMATION STUDIES VIA SIXTRACK -----
16276 !----- -----
16277 !----- G. ROBERT-DEMOLAIZE, November 1st, 2004 -----
16278 !----- -----
16279 !-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----
16280 !
16281 !
16282 !++ Based on routines by JBJ. Changed by RA 2001.
16283 !
16284 !
16285 !GRD
16286 !GRD MODIFIED VERSION FOR COLLIMATION SYSTEM: G. ROBERT-DEMOLAIZE
16287 !GRD
16288 !
16289 !++ - Deleted all HBOOK stuff.
16290 !++ - Deleted optics routine and all parser routines.
16291 !++ - Replaced RANMAR call by RANLUX call
16292 !++ - Included RANLUX code from CERNLIB into source
16293 !++ - Changed dimensions from CGen(100,nmat) to CGen(200,nmat)
16294 !++ - Replaced FUNPRE with FUNLXP
16295 !++ - Replaced FUNRAN with FUNLUX
16296 !++ - Included all CERNLIB code into source: RANLUX, FUNLXP, FUNLUX,
16297 !++ FUNPCT, FUNLZ, RADAPT,
16298 !++ RGS56P
16299 !++ with additional entries: RLUXIN, RLUXUT, RLUXAT,
16300 !++ RLUXGO
16301 !++
16302 !++ - Changed program so that Nev is total number of particles
16303 !++ (scattered and not-scattered)
16304 !++ - Added debug comments
16305 !++ - Put real dp/dx
16306 !
16307 implicit none
16308 !
16309 character*16 name_coll
16310 integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1, &
16311 &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran, &
16312 &nrco,ntr,nzfz
16313 parameter(npart = 64,nmac = 1)
16314 parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000, &
16315 &nzfz = 300000,mmul = 11)
16316 parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5, &
16317 &nema = 15)
16318 parameter(mcor = 10,mcop = mcor+6, mbea = 15)
16319 parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
16320 parameter(nmon1 = 600,ncor1 = 600)
16321 parameter(ntr = 20,nbb = 160)
16322 integer max_ncoll,max_npart,maxn,numeff,outlun,nc
16323 !UPGRADE January 2005
16324 ! PARAMETER (MAX_NCOLL=68,MAX_NPART=20000,nc=32,NUMEFF=19,
16325 parameter (max_ncoll=100,max_npart=20000,nc=32,numeff=19, &
16326 &maxn=20000,outlun=54)
16327 !
16328 ! THIS BLOCK IS COMMON TO THIN6D, TRAUTHIN, COLLIMATE32 AND MAINCR
16329 !
16330 integer ipencil
16331 double precision xp_pencil0,yp_pencil0,x_pencil(max_ncoll), &
16332 &y_pencil(max_ncoll),pencil_dx(max_ncoll)
16333 common /pencil/ xp_pencil0,yp_pencil0,pencil_dx,ipencil
16334 common /pencil2/ x_pencil, y_pencil
16335 !
16336 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
16337 !
16338 integer ie,iturn,nabs_total
16339 common /info/ ie,iturn,nabs_total
16340 !
16341 !
16342 logical onesided,hit
16343 integer nprim,filel,mat,nev,j,nabs,nhit,np,icoll
16344 !MAY2005
16345 ! integer lhit(npart),part_abs(npart)
16346 integer lhit(npart),part_abs(npart),name(npart)
16347 !MAY2005
16348 double precision p0,xmin,xmax,xpmin,xpmax,zmin,zmax,zpmin,zpmax &
16349 &,length,zlm,x,x00,xp,z,z00,zp,p,sp,dpop,s,enom,x_in(npart), &
16350 &xp_in(npart),y_in(npart),yp_in(npart),p_in(npart),s_in(npart), &
16351 &indiv(npart),lint(npart),x_out(max_npart),xp_out(max_npart), &
16352 &y_out(max_npart),yp_out(max_npart),p_out(max_npart), &
16353 &s_out(max_npart),keeps,fracab,mybetax,mybetaz,mymux,mymuz,sigx, &
16354 &sigz,norma,xpmu,atdi,drift_length,mirror,tiltangle,impact(npart)
16355 !
16356 double precision c_length !length in m
16357 double precision c_rotation !rotation angle vs vertical in radian
16358 double precision c_aperture !aperture in m
16359 double precision c_offset !offset in m
16360 double precision c_tilt(2) !tilt in radian
16361 character*6 c_material !material
16362 !
16363 !
16364 !
16365 character*(nc) filen,tit
16366 !
16367 real rndm4,xlow,xhigh,xplow,xphigh,dx,dxp
16368 !
16369 !AUGUST2006 Added ran_gauss for generation of pencil/ ------- TW
16370 ! sheet beam distribution (smear in x and y)
16371 !
16372 double precision ran_gauss
16373 !
16374 common /cmom/xmin,xmax,xpmin,xpmax,zmin,zmax,zpmin,zpmax,length, &
16375 &nev
16376 common /materia/mat
16377 common /phase/x,xp,z,zp,dpop
16378 common /nommom/p0
16379 common /cjaw1/zlm
16380 common /other/mybetax,mybetaz,mymux,mymuz,atdi
16381 common /icoll/ icoll
16382 !
16383 data dx,dxp/.5d-4,20.d-4/
16384 !
16385 !
16386 !
16387 !GRD
16388 !GRD THIS BLOC IS COMMON TO MAINCR, DATEN, TRAUTHIN AND THIN6D
16389 !GRD
16390 !APRIL2005
16391 logical do_coll,do_select,do_nominal,dowrite_dist,do_oneside, &
16392 &dowrite_impact,dowrite_secondary,dowrite_amplitude,radial, &
16393 &systilt_antisymm,dowritetracks,cern,do_nsig,do_mingap
16394 !SEPT2005 for slicing process
16395 integer nloop,rnd_seed,c_offsettilt_seed,ibeam,jobnumber, &
16396 &do_thisdis,n_slices,pencil_distr
16397 !JUNE2005
16398 double precision myenom,mynex,mdex,myney,mdey, &
16399 &nsig_tcp3,nsig_tcsg3,nsig_tcsm3,nsig_tcla3, &
16400 &nsig_tcp7,nsig_tcsg7,nsig_tcsm7,nsig_tcla7,nsig_tclp,nsig_tcli, &
16401 !
16402 &nsig_tcth1,nsig_tcth2,nsig_tcth5,nsig_tcth8, &
16403 &nsig_tctv1,nsig_tctv2,nsig_tctv5,nsig_tctv8, &
16404 !
16405 &nsig_tcdq,nsig_tcstcdq,nsig_tdi,nsig_tcxrp,nsig_tcryo, nsig_cry, &
16406 !SEPT2005 add these lines for the slicing procedure
16407 &smin_slices,smax_slices,recenter1,recenter2, &
16408 &fit1_1,fit1_2,fit1_3,fit1_4,fit1_5,fit1_6,ssf1, &
16409 &fit2_1,fit2_2,fit2_3,fit2_4,fit2_5,fit2_6,ssf2, &
16410 !SEPT2005,OCT2006 added offset
16411 &emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase, &
16412 &c_rmstilt_prim,c_rmstilt_sec,c_systilt_prim,c_systilt_sec, &
16413 &c_rmsoffset_prim,c_rmsoffset_sec,c_sysoffset_prim, &
16414 &c_sysoffset_sec,c_rmserror_gap,nr,ndr, &
16415 ! &driftsx,driftsy,pencil_offset,sigsecut3
16416 !JUNE2005
16417 ! &driftsx,driftsy,pencil_offset,sigsecut3,sigsecut2
16418 &driftsx,driftsy,pencil_offset,pencil_rmsx,pencil_rmsy, &
16419 &sigsecut3,sigsecut2,enerror,bunchlength
16420 !JUNE2005
16421 !APRIL2005
16422 !
16423 character*24 name_sel
16424 character*80 coll_db
16425 character*16 castordir
16426 !JUNE2005
16427 character*80 filename_dis
16428 !JUNE2005
16429 !
16430 common /grd/ myenom,mynex,mdex,myney,mdey, &
16431 &nsig_tcp3,nsig_tcsg3,nsig_tcsm3,nsig_tcla3, &
16432 &nsig_tcp7,nsig_tcsg7,nsig_tcsm7,nsig_tcla7,nsig_tclp,nsig_tcli, &
16433 !
16434 &nsig_tcth1,nsig_tcth2,nsig_tcth5,nsig_tcth8, &
16435 &nsig_tctv1,nsig_tctv2,nsig_tctv5,nsig_tctv8, &
16436 !
16437 &nsig_tcdq,nsig_tcstcdq,nsig_tdi,nsig_tcxrp,nsig_tcryo,nsig_cry, &
16438 !
16439 &smin_slices,smax_slices,recenter1,recenter2, &
16440 &fit1_1,fit1_2,fit1_3,fit1_4,fit1_5,fit1_6,ssf1, &
16441 &fit2_1,fit2_2,fit2_3,fit2_4,fit2_5,fit2_6,ssf2, &
16442 !
16443 &emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase, &
16444 &c_rmstilt_prim,c_rmstilt_sec,c_systilt_prim,c_systilt_sec, &
16445 &c_rmsoffset_prim,c_rmsoffset_sec,c_sysoffset_prim, &
16446 &c_sysoffset_sec,c_rmserror_gap,nr, &
16447 !
16448 &ndr,driftsx,driftsy,pencil_offset,pencil_rmsx,pencil_rmsy, &
16449 &sigsecut3,sigsecut2,enerror, &
16450 &bunchlength,coll_db,name_sel, &
16451 &castordir,filename_dis,nloop,rnd_seed,c_offsettilt_seed, &
16452 &ibeam,jobnumber,do_thisdis,n_slices,pencil_distr, &
16453 &do_coll, &
16454 !
16455 &do_select,do_nominal,dowrite_dist,do_oneside,dowrite_impact, &
16456 &dowrite_secondary,dowrite_amplitude,radial,systilt_antisymm, &
16457 &dowritetracks,cern,do_nsig,do_mingap
16458 !SEPT2005
16459 !JUNE2005
16460 !APRIL2005
16461 !
16462 !--September 2006 -- TW common to readcollimator and collimate2
16463 ! logical changed_tilt1(max_ncoll)
16464 ! logical changed_tilt2(max_ncoll)
16465 ! common /tilt/ changed_tilt1, changed_tilt2
16466 !--September 2006
16467 !
16468 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
16469 !
16470 !
16471 double precision x_flk,xp_flk,y_flk,yp_flk
16472 !
16473 double precision s_impact
16474 integer flagsec(maxn)
16475 !
16476 ! SR, 18-08-2005: add temporary variable to write in FirstImpacts
16477 ! the initial distribution of the impacting particles in the
16478 ! collimator frame.
16479 double precision xinn,xpinn,yinn,ypinn
16480 !
16481 ! SR, 29-08-2005: add the slice number to calculate the impact
16482 ! location within the collimator.
16483 ! j_slices = 1 for the a non sliced collimator!
16484 integer j_slices
16485 !
16486 save
16487 !
16488 common /Process/ bool_proc,bool_create
16489 integer bool_proc(maxn)
16490 logical bool_create
16491 !=======================================================================
16492 ! Be=1 Al=2 Cu=3 W=4 Pb=5
16493 !
16494 ! LHC uses: Al, 0.2 m
16495 ! Cu, 1.0 m
16496 !
16497 ! write(*,*) 'enter collimate2 routine'
16498 if (c_material.eq.'BE') then
16499 mat = 1
16500 elseif (c_material.eq.'Be') then
16501 mat = 1
16502 elseif (c_material.eq.'AL') then
16503 mat = 2
16504 elseif (c_material.eq.'Al') then
16505 mat = 2
16506 elseif (c_material.eq.'CU') then
16507 mat = 3
16508 elseif (c_material.eq.'Cu') then
16509 mat = 3
16510 elseif (c_material.eq.'W') then
16511 mat = 4
16512 elseif (c_material.eq.'PB') then
16513 mat = 5
16514 elseif (c_material.eq.'Pb') then
16515 mat = 5
16516 elseif (c_material.eq.'C') then
16517 mat = 6
16518 elseif (c_material.eq.'C2') then
16519 mat = 7
16520 !02/2008 TW added vacuum and black absorber (was missing)
16521 elseif (c_material.eq.'VA') then
16522 mat = 11
16523 elseif (c_material.eq.'BL') then
16524 mat = 12
16525 else
16526 write(*,*) 'ERR> Material not found. STOP (TW)', c_material
16527 ! STOP
16528 endif
16529 !
16530 length = c_length
16531 nev = np
16532 p0 = enom
16533 !
16534 !++ Initialize scattering processes
16535 !
16536 call scatin(p0)
16537
16538 ! EVENT LOOP, initial distribution is here a flat distribution with
16539 ! xmin=x-, xmax=x+, etc. from the input file
16540 !
16541 nhit = 0
16542 fracab = 0d0
16543 mirror = 1d0
16544 !
16545 !==> SLICE here
16546 !
16547
16548 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
16549 do j = 1, nev
16550 !
16551 ! SR-GRD (04-08-2005):
16552 ! Don't do scattering process for particles already absorbed
16553 if (part_abs(j) .ne. 0) goto 777
16554 impact(j) = -1d0
16555 lint(j) = -1d0
16556 indiv(j) = -1d0
16557 x = x_in(j)
16558 xp = xp_in(j)
16559 z = y_in(j)
16560 zp = yp_in(j)
16561 p = p_in(j)
16562 sp = 0d0
16563 dpop = (p - p0)/p0
16564 x_flk = 0d0
16565 y_flk = 0d0
16566 xp_flk = 0d0
16567 yp_flk = 0d0
16568 !
16569 !++ Transform particle coordinates to get into collimator coordinate
16570 !++ system
16571 !
16572 !++ First do rotation into collimator frame
16573 !
16574 x = x_in(j)*cos(c_rotation) +sin(c_rotation)*y_in(j)
16575 z = y_in(j)*cos(c_rotation) -sin(c_rotation)*x_in(j)
16576 xp = xp_in(j)*cos(c_rotation)+sin(c_rotation)*yp_in(j)
16577 zp = yp_in(j)*cos(c_rotation)-sin(c_rotation)*xp_in(j)
16578 !
16579 !++ For one-sided collimators consider only positive X. For negative
16580 !++ X jump to the next particle
16581 !
16582 if (name_coll(6:8).eq."SPS") then
16583 if (x.gt.0) goto 777
16584 else
16585 if (onesided .and. x.lt.0) goto 777
16586 endif
16587
16588 !
16589 !++ Now mirror at the horizontal axis for negative X offset
16590 !
16591 if (x.lt.0) then
16592 mirror = -1d0
16593 tiltangle = -1d0*c_tilt(2)
16594 endif
16595 if (x.ge.0) then
16596 mirror = 1d0
16597 tiltangle = c_tilt(1)
16598 endif
16599 x = mirror * x
16600 xp = mirror * xp
16601 x = x - c_aperture/2 - mirror*c_offset
16602 !++ Include collimator tilt
16603 if (tiltangle.gt.0.) then
16604 xp = xp - tiltangle
16605 endif
16606 if (tiltangle.lt.0.) then
16607 x = x + sin(tiltangle) * c_length
16608 xp = xp - tiltangle
16609 endif
16610 c------------------------------------------------------------------------
16611 c PENCIL BEAM
16612 !++ For selected collimator, first turn reset particle distribution
16613 !++ to simple pencil beam
16614 !
16615 ! -- TW why did I set this to 0, seems to be needed for getting
16616 ! right amplitude => no "tilt" of jaw for the first turn !!!!
16617 nprim = 3
16618 if ( (icoll.eq.ipencil .and. iturn.eq.1) .or. (iturn.eq.1 &
16619 & .and. ipencil.eq.999 .and. icoll.le.nprim .and. &
16620 & (j.ge.(icoll-1)*nev/nprim) .and. (j.le.(icoll)*nev/nprim))) then
16621 ! -- TW why did I set this to 0, seems to be needed for getting
16622 ! right amplitude => no "tilt" of jaw for the first turn !!!!
16623 c_tilt(1) = 0d0
16624 c_tilt(2) = 0d0
16625 !AUGUST2006: Standard pencil beam as implemented by GRD ------- TW
16626 if (pencil_rmsx.eq.0. .and. pencil_rmsy.eq.0.) then
16627 x = pencil_dx(icoll)
16628 xp = 0.
16629 z = 0.
16630 zp = 0.
16631 endif
16632 !
16633 !AUGUST2006: Rectangular (pencil-beam) sheet-beam with ------ TW
16634 ! pencil_offset is the rectangulars center
16635 ! pencil_rmsx defines spread of impact parameter
16636 ! pencil_rmsy defines spread parallel to jaw surface
16637 !
16638 if (pencil_distr.eq.0 .and.(pencil_rmsx.ne.0. &
16639 & .or.pencil_rmsy.ne.0.)) then
16640 ! how to assure that all generated particles are on the jaw ?!
16641 x = pencil_dx(icoll) &
16642 & + pencil_rmsx*(rndm4()-0.5)
16643 xp = 0.
16644 z = pencil_rmsy*(rndm4()-0.5)
16645 zp = 0.
16646 endif
16647 !
16648 !AUGUST2006: Gaussian (pencil-beam) sheet-beam with ------- TW
16649 ! pencil_offset is the mean gaussian distribution
16650 ! pencil_rmsx defines spread of impact parameter
16651 ! pencil_rmsy defines spread parallel to jaw surface
16652 !
16653 if (pencil_distr.eq.1 .and.(pencil_rmsx.ne.0. &
16654 & .or.pencil_rmsy.ne.0. )) then
16655 x =pencil_dx(icoll)+pencil_rmsx*ran_gauss(2d0)
16656 ! all generated particles are on the jaw now
16657 x = sqrt(x**2)
16658 xp = 0.
16659 z = pencil_rmsy*ran_gauss(2d0)
16660 zp = 0.
16661 endif
16662 !AUGUST2006: Gaussian (pencil-beam) sheet-beam with ------- TW
16663 ! pencil_offset is the mean gaussian distribution
16664 ! pencil_rmsx defines spread of impact parameter
16665 ! here pencil_rmsx is not gaussian!!!
16666 ! pencil_rmsy defines spread parallel to jaw surface
16667 !
16668 if (pencil_distr.eq.2 .and.(pencil_rmsx.ne.0. &
16669 & .or.pencil_rmsy.ne.0. )) then
16670 x = pencil_dx(icoll) &
16671 & + pencil_rmsx*(rndm4()-0.5)
16672 ! all generated particles are on the jaw now
16673 x = sqrt(x**2)
16674 xp = 0.
16675 z = pencil_rmsy*ran_gauss(2d0)
16676 zp = 0.
16677 endif
16678 !JULY2007: Selection of pos./neg. jaw implemented by GRD ---- TW
16679 ! ensure that for onesided only particles on pos. jaw are created
16680 if (onesided) then
16681 mirror = 1d0
16682 else
16683 if(rndm4().lt.0.5) then
16684 mirror = -1d0
16685 else
16686 mirror = 1d0
16687 endif
16688 endif
16689 ! -- TW SEP07 if c_tilt is set to zero before entering pencil beam
16690 ! section the assigning of the tilt will result in
16691 ! assigning zeros
16692 if (mirror.lt.0) then
16693 tiltangle = c_tilt(2)
16694 else
16695 tiltangle = c_tilt(1)
16696 endif
16697 c write(9997,'(f10.8,(2x,f10.8),(2x,f10.8),(2x,f10.8)(2x,f10.8))')
16698 c & x, xp, z, zp, tiltangle
16699 endif !!!!!end of the pencil beam stuff!!!!!
16700 c------------------------------------------------------------------------
16701 ! SR, 18-08-2005: after finishing the coordinate transformation,
16702 ! or the coordinate manipulations in case of pencil beams,
16703 ! write down the initial coordinates of the impacting particles
16704 xinn = x
16705 xpinn = xp
16706 yinn = z
16707 ypinn = zp
16708 !
16709 !++ particle passing above the jaw are discarded => take new event
16710 !++ entering by the face, shorten the length (zlm) and keep track of
16711 !++ entrance longitudinal coordinate (keeps) for histograms
16712 !
16713 !++ The definition is that the collimator jaw is at x>=0.
16714 !
16715 !++ 1) Check whether particle hits the collimator
16716 !
16717 hit = .false.
16718 s = 0.
16719 keeps = 0.
16720 zlm = -1d0 * length
16721 !
16722 if (x.ge.0.) then
16723 !
16724 !++ Particle hits collimator and we assume interaction length ZLM equal
16725 !++ to collimator length (what if it would leave collimator after
16726 !++ small length due to angle???)
16727 !
16728 zlm = length
16729 impact(j) = x
16730 indiv(j) = xp
16731 else if (xp.le.0.) then
16732 !++ Particle does not hit collimator. Interaction length ZLM is zero.
16733 zlm = 0d0
16734 else
16735 !++ Calculate s-coordinate of interaction point
16736 s = (-1d0*x) / xp
16737 if (s.le.0) then
16738 write(*,*) 'S.LE.0 -> This should not happen'
16739 stop
16740 endif
16741 if (s .lt. length) then
16742 zlm = length - s
16743 impact(j) = 0d0
16744 indiv(j) = xp
16745 else
16746 zlm = 0d0
16747 endif
16748 endif
16749 !++ First do the drift part
16750 drift_length = length - zlm
16751 if (drift_length.gt.0.) then
16752 x = x + xp* drift_length
16753 z = z + zp * drift_length
16754 sp = sp + drift_length
16755 endif
16756 !++ Now do the scattering part
16757 if (zlm.gt.0.) then
16758 s_impact = sp
16759 nhit = nhit + 1
16760 call jaw(s, nabs)
16761 !JUNE2005 SR+GRD: CREATE A FILE TO CHECK THE VALUES OF IMPACT PARAMETERS
16762 ! SR, 29-08-2005: Add to the longitudinal coordinates the position
16763 ! of the slice beginning
16764 if(dowrite_impact) then
16765 if(flagsec(j).eq.0) then
16766 write(39,'(i5,1x,i7,1x,i2,1x,i1,
16767 & 2(1x,f5.3),8(1x,e17.9))') &
16768 & name(j),iturn,icoll,nabs, &
16769 & s_impact + (dble(j_slices)-1)* c_length,&
16770 & s+sp + (dble(j_slices)-1) * c_length, &
16771 & xinn,xpinn,yinn,ypinn, &
16772 & x,xp,z,zp
16773 endif
16774 endif
16775 lhit(j) = 10000*ie + iturn
16776 !++ If particle is absorbed then set x and y to 99.99 mm
16777 ! SR: before assigning new (x,y) for nabs=1, write the
16778 ! inelastic impact file .
16779 if (nabs.eq.1) then
16780 if (tiltangle.gt.0.) then
16781 x = x + tiltangle*(s+sp)
16782 xp = xp + tiltangle
16783 elseif (tiltangle.lt.0.) then
16784 xp = xp + tiltangle
16785 x = x - sin(tiltangle)* (length-(s+sp))
16786 endif
16787 x = x + c_aperture/2d0 + mirror*c_offset
16788 x = mirror * x
16789 xp = mirror * xp
16790 x_flk = x *cos(-1d0*c_rotation) + &
16791 & z *sin(-1d0*c_rotation)
16792 y_flk = z *cos(-1d0*c_rotation) - &
16793 & x *sin(-1d0*c_rotation)
16794 xp_flk = xp *cos(-1d0*c_rotation) + &
16795 & zp *sin(-1d0*c_rotation)
16796 yp_flk = zp *cos(-1d0*c_rotation) - &
16797 & xp *sin(-1d0*c_rotation)
16798 ! SR, 29-08-2005: Include the slice numer!
16799 if(dowrite_impact) then
16800 write(48,'(i4,(1x,f6.3),(1x,f8.6),4(1x,e19.10), &
16801 & i2,2(1x,i7))') &
16802 & icoll,c_rotation, &
16803 & s + sp + (dble(j_slices)-1) * c_length, &
16804 & x_flk*1d3, xp_flk*1d3, y_flk*1d3, yp_flk*1d3, &
16805 & nabs,name(j),iturn
16806 write(866,*)
16807 & name(j), iturn, icoll, bool_proc(j)
16808 endif
16809 ! Finally, the actual coordinate change to 99 mm
16810 fracab = fracab + 1
16811 x = 99.99d-3
16812 z = 99.99d-3
16813 part_abs(j) = 10000*ie + iturn
16814 lint(j) = zlm
16815 endif
16816 endif
16817 !
16818 !++ Do the rest drift, if particle left collimator early
16819 !
16820 if (nabs.ne.1 .and. zlm.gt.0.) then
16821 drift_length = (length-(s+sp))
16822 if (drift_length.gt.1d-15) then
16823 x = x + xp * drift_length
16824 z = z + zp * drift_length
16825 sp = sp + drift_length
16826 endif
16827 lint(j) = zlm - drift_length
16828 endif
16829 !
16830 !++ Transform back to particle coordinates with opening and offset
16831 if (x.lt.99.0d-3) then
16832 !++ Include collimator tilt
16833 if (tiltangle.gt.0.) then
16834 x = x + tiltangle*c_length
16835 xp = xp + tiltangle
16836 elseif (tiltangle.lt.0.) then
16837 x = x + tiltangle*c_length
16838 xp = xp + tiltangle
16839 x = x - sin(tiltangle) * c_length
16840 endif
16841 !++ Transform back to particle coordinates with opening and offset
16842 z00 = z
16843 x00 = x + mirror*c_offset
16844 x = x + c_aperture/2d0 + mirror*c_offset
16845 !++ Now mirror at the horizontal axis for negative X offset
16846 x = mirror * x
16847 xp = mirror * xp
16848 !++ Last do rotation into collimator frame
16849 !
16850 x_in(j) = x *cos(-1d0*c_rotation) + &
16851 & z *sin(-1d0*c_rotation)
16852 y_in(j) = z *cos(-1d0*c_rotation) - &
16853 & x *sin(-1d0*c_rotation)
16854 xp_in(j) = xp *cos(-1d0*c_rotation) + &
16855 & zp *sin(-1d0*c_rotation)
16856 yp_in(j) = zp *cos(-1d0*c_rotation) - &
16857 & xp *sin(-1d0*c_rotation)
16858 !
16859 if ( (icoll.eq.ipencil &
16860 & .and. iturn.eq.1) .or. &
16861 & (iturn.eq.1 .and. ipencil.eq.999 .and. &
16862 & icoll.le.nprim .and. &
16863 & (j.ge.(icoll-1)*nev/nprim) .and. &
16864 & (j.le.(icoll)*nev/nprim) &
16865 & ) ) then
16866 !
16867 x00 = mirror * x00
16868 x_in(j) = x00 *cos(-1d0*c_rotation) + &
16869 & z00 *sin(-1d0*c_rotation)
16870 y_in(j) = z00 *cos(-1d0*c_rotation) - &
16871 & x00 *sin(-1d0*c_rotation)
16872 !
16873 xp_in(j) = xp_in(j) + mirror*xp_pencil0
16874 yp_in(j) = yp_in(j) + mirror*yp_pencil0
16875 x_in(j) = x_in(j) + mirror*x_pencil(icoll)
16876 y_in(j) = y_in(j) + mirror*y_pencil(icoll)
16877 endif
16878 p_in(j) = (1d0 + dpop) * p0
16879 ! SR, 30-08-2005: add the initial position of the slice
16880 s_in(j) = sp + (dble(j_slices)-1) * c_length
16881 else
16882 x_in(j) = x
16883 y_in(j) = z
16884 endif
16885 777 end do
16886 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
16887 !
16888 ! WRITE(*,*) 'Number of particles: ', Nev
16889 ! WRITE(*,*) 'Number of particle hits: ', Nhit
16890 ! WRITE(*,*) 'Number of absorped particles: ', fracab
16891 ! WRITE(*,*) 'Number of escaped particles: ', Nhit-fracab
16892 ! WRITE(*,*) 'Fraction of absorped particles: ', 100.*fracab/Nhit
16893 !
16894 end
16895 !
16896 !-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----
16897 !
16898 subroutine collimaterhic(c_material, c_length, c_rotation, &
16899 !JUNE2005
16900 &c_aperture, n_aperture, &
16901 !JUNE2005
16902 &c_offset, c_tilt, &
16903 &x_in, xp_in, y_in, &
16904 &yp_in, p_in, s_in, np, enom, lhit, &
16905 ! &part_abs, impact, indiv, lint, onesided)
16906 &part_abs, impact, indiv, lint, onesided, &
16907 &name)
16908 !
16909 !++ Based on routines by JBJ. Changed by RA 2001.
16910 !
16911 !++ - Deleted all HBOOK stuff.
16912 !++ - Deleted optics routine and all parser routines.
16913 !++ - Replaced RANMAR call by RANLUX call
16914 !++ - Included RANLUX code from CERNLIB into source
16915 !++ - Changed dimensions from CGen(100,nmat) to CGen(200,nmat)
16916 !++ - Replaced FUNPRE with FUNLXP
16917 !++ - Replaced FUNRAN with FUNLUX
16918 !++ - Included all CERNLIB code into source: RANLUX, FUNLXP, FUNLUX,
16919 !++ FUNPCT, FUNLZ, RADAPT,
16920 !++ RGS56P
16921 !++ with additional entries: RLUXIN, RLUXUT, RLUXAT,
16922 !++ RLUXGO
16923 !++
16924 !++ - Changed program so that Nev is total number of particles
16925 !++ (scattered and not-scattered)
16926 !++ - Added debug comments
16927 !++ - Put real dp/dx
16928 !
16929 implicit none
16930 !
16931 double precision sx, sz
16932 !
16933 integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1, &
16934 &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran, &
16935 &nrco,ntr,nzfz
16936 parameter(npart = 64,nmac = 1)
16937 parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000, &
16938 &nzfz = 300000,mmul = 11)
16939 parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5, &
16940 &nema = 15)
16941 parameter(mcor = 10,mcop = mcor+6, mbea = 15)
16942 parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
16943 parameter(nmon1 = 600,ncor1 = 600)
16944 parameter(ntr = 20,nbb = 160)
16945 integer max_ncoll,max_npart,maxn,numeff,outlun,nc
16946 !UPGRADE January 2005
16947 ! PARAMETER (MAX_NCOLL=68,MAX_NPART=20000,nc=32,NUMEFF=19,
16948 parameter (max_ncoll=100,max_npart=20000,nc=32,numeff=19, &
16949 &maxn=20000,outlun=54)
16950 !
16951 ! THIS BLOCK IS COMMON TO THIN6D, TRAUTHIN, COLLIMATE32 AND MAINCR
16952 !
16953 integer ipencil
16954 double precision xp_pencil0,yp_pencil0,x_pencil(max_ncoll), &
16955 &y_pencil(max_ncoll),pencil_dx(max_ncoll)
16956 common /pencil/ xp_pencil0,yp_pencil0,pencil_dx,ipencil
16957 common /pencil2/ x_pencil, y_pencil
16958 !
16959 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
16960 !
16961 integer ie,iturn,nabs_total
16962 common /info/ ie,iturn,nabs_total
16963 !
16964 !
16965 logical onesided,hit
16966 integer nprim,filel,mat,nev,j,nabs,nhit,np,icoll
16967 !MAY2005
16968 ! integer lhit(npart),part_abs(npart)
16969 integer lhit(npart),part_abs(npart),name(npart)
16970 !MAY2005
16971 double precision p0,xmin,xmax,xpmin,xpmax,zmin,zmax,zpmin,zpmax &
16972 &,length,zlm,x,x00,xp,z,z00,zp,p,sp,dpop,s,enom,x_in(npart), &
16973 &xp_in(npart),y_in(npart),yp_in(npart),p_in(npart),s_in(npart), &
16974 &indiv(npart),lint(npart),x_out(max_npart),xp_out(max_npart), &
16975 &y_out(max_npart),yp_out(max_npart),p_out(max_npart), &
16976 &s_out(max_npart),keeps,fracab,mybetax,mybetaz,mymux,mymuz,sigx, &
16977 &sigz,norma,xpmu,atdi,drift_length,mirror,tiltangle,impact(npart)
16978 !
16979 double precision c_length !length in m
16980 double precision c_rotation !rotation angle vs vertical in radian
16981 double precision c_aperture !aperture in m
16982 double precision c_offset !offset in m
16983 double precision c_tilt(2) !tilt in radian
16984 character*6 c_material !material
16985 !
16986 !
16987 !
16988 character*(nc) filen,tit
16989 !
16990 real rndm4,xlow,xhigh,xplow,xphigh,dx,dxp
16991 !
16992 common /cmom/xmin,xmax,xpmin,xpmax,zmin,zmax,zpmin,zpmax,length, &
16993 &nev
16994 common /materia/mat
16995 common /phase/x,xp,z,zp,dpop
16996 common /nommom/p0
16997 common /cjaw1/zlm
16998 common /other/mybetax,mybetaz,mymux,mymuz,atdi
16999 common /icoll/ icoll
17000 !
17001 data dx,dxp/.5d-4,20.d-4/
17002 !
17003 !
17004 !
17005 !GRD
17006 !GRD THIS BLOC IS COMMON TO MAINCR, DATEN, TRAUTHIN AND THIN6D
17007 !GRD
17008 !APRIL2005
17009 logical do_coll,do_select,do_nominal,dowrite_dist,do_oneside, &
17010 &dowrite_impact,dowrite_secondary,dowrite_amplitude,radial, &
17011 &systilt_antisymm,dowritetracks,cern,do_nsig,do_mingap
17012 ! &systilt_antisymm,dowritetracks,cern
17013 !APRIL2005
17014 !
17015 ! integer nloop,rnd_seed,ibeam,jobnumber,sigsecut2
17016 !JUNE2005
17017 ! integer nloop,rnd_seed,ibeam,jobnumber
17018 !SEPT2005 for slicing process
17019 ! integer nloop,rnd_seed,ibeam,jobnumber,do_thisdis
17020 integer nloop,rnd_seed,c_offsettilt_seed,ibeam,jobnumber, &
17021 &do_thisdis,n_slices,pencil_distr
17022 !JUNE2005
17023 !
17024 !UPGRADE JANUARY 2005
17025 !APRIL2005
17026 ! double precision myenom,mynex,mdex,myney,mdey,nsig_prim,nsig_sec, &
17027 ! &nsig_ter,emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase, &
17028 double precision myenom,mynex,mdex,myney,mdey, &
17029 &nsig_tcp3,nsig_tcsg3,nsig_tcsm3,nsig_tcla3, &
17030 &nsig_tcp7,nsig_tcsg7,nsig_tcsm7,nsig_tcla7,nsig_tclp,nsig_tcli, &
17031 !
17032 &nsig_tcth1,nsig_tcth2,nsig_tcth5,nsig_tcth8, &
17033 &nsig_tctv1,nsig_tctv2,nsig_tctv5,nsig_tctv8, &
17034 !
17035 &nsig_tcdq,nsig_tcstcdq,nsig_tdi,nsig_tcxrp,nsig_tcryo, nsig_cry, &
17036 !SEPT2005 add these lines for the slicing procedure
17037 &smin_slices,smax_slices,recenter1,recenter2, &
17038 &fit1_1,fit1_2,fit1_3,fit1_4,fit1_5,fit1_6,ssf1, &
17039 &fit2_1,fit2_2,fit2_3,fit2_4,fit2_5,fit2_6,ssf2, &
17040 !SEPT2005,OCT2006 added offset
17041 &emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase, &
17042 &c_rmstilt_prim,c_rmstilt_sec,c_systilt_prim,c_systilt_sec, &
17043 &c_rmsoffset_prim,c_rmsoffset_sec,c_sysoffset_prim, &
17044 &c_sysoffset_sec,c_rmserror_gap,nr,ndr, &
17045 ! &driftsx,driftsy,pencil_offset,sigsecut3
17046 !JUNE2005
17047 ! &driftsx,driftsy,pencil_offset,sigsecut3,sigsecut2
17048 &driftsx,driftsy,pencil_offset,pencil_rmsx,pencil_rmsy, &
17049 &sigsecut3,sigsecut2,enerror,bunchlength
17050 !JUNE2005
17051 !APRIL2005
17052 !
17053 character*24 name_sel
17054 character*80 coll_db
17055 character*16 castordir
17056 !JUNE2005
17057 character*80 filename_dis
17058 !JUNE2005
17059 !
17060 !UPGRADE JANUARY 2005
17061 !APRIL2005
17062 !JUNE2005
17063 !SEPT2005
17064 ! common /grd/ myenom,mynex,mdex,myney,mdey,nsig_prim,nsig_sec, &
17065 ! &nsig_ter,emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase, &
17066 ! &c_rmstilt_prim,c_rmstilt_sec,c_systilt_prim,c_systilt_sec,nr, &
17067 ! &ndr,driftsx,driftsy,pencil_offset,sigsecut3,coll_db,name_sel, &
17068 ! &castordir,abs_db,nloop,rnd_seed,ibeam,jobnumber,sigsecut2,do_coll,&
17069 ! &do_select,do_nominal,dowrite_dist,do_oneside,dowrite_impact, &
17070 ! &dowrite_secondary,dowrite_amplitude,radial,systilt_antisymm, &
17071 ! &dowritetracks,cern
17072 common /grd/ myenom,mynex,mdex,myney,mdey, &
17073 &nsig_tcp3,nsig_tcsg3,nsig_tcsm3,nsig_tcla3, &
17074 &nsig_tcp7,nsig_tcsg7,nsig_tcsm7,nsig_tcla7,nsig_tclp,nsig_tcli, &
17075 !
17076 &nsig_tcth1,nsig_tcth2,nsig_tcth5,nsig_tcth8, &
17077 &nsig_tctv1,nsig_tctv2,nsig_tctv5,nsig_tctv8, &
17078 !
17079 &nsig_tcdq,nsig_tcstcdq,nsig_tdi,nsig_tcxrp,nsig_tcryo, nsig_cry, &
17080 !
17081 &smin_slices,smax_slices,recenter1,recenter2, &
17082 &fit1_1,fit1_2,fit1_3,fit1_4,fit1_5,fit1_6,ssf1, &
17083 &fit2_1,fit2_2,fit2_3,fit2_4,fit2_5,fit2_6,ssf2, &
17084 !
17085 &emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase, &
17086 &c_rmstilt_prim,c_rmstilt_sec,c_systilt_prim,c_systilt_sec, &
17087 &c_rmsoffset_prim,c_rmsoffset_sec,c_sysoffset_prim, &
17088 &c_sysoffset_sec,c_rmserror_gap,nr, &
17089 !
17090 &ndr,driftsx,driftsy,pencil_offset,pencil_rmsx,pencil_rmsy, &
17091 &sigsecut3,sigsecut2,enerror, &
17092 &bunchlength,coll_db,name_sel, &
17093 &castordir,filename_dis,nloop,rnd_seed,c_offsettilt_seed, &
17094 &ibeam,jobnumber,do_thisdis,n_slices,pencil_distr, &
17095 &do_coll, &
17096 !
17097 &do_select,do_nominal,dowrite_dist,do_oneside,dowrite_impact, &
17098 &dowrite_secondary,dowrite_amplitude,radial,systilt_antisymm, &
17099 &dowritetracks,cern,do_nsig,do_mingap
17100 !SEPT2005
17101 !JUNE2005
17102 !APRIL2005
17103 !
17104 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
17105 !
17106 !
17107 double precision x_flk,xp_flk,y_flk,yp_flk
17108 !JUNE2005
17109 double precision n_aperture !aperture in m for the vertical plane
17110 !JUNE2005
17111 !DEBUG
17112 integer event
17113 !DEBUG
17114 save
17115 !=======================================================================
17116 ! Be=1 Al=2 Cu=3 W=4 Pb=5
17117 !
17118 ! LHC uses: Al, 0.2 m
17119 ! Cu, 1.0 m
17120 !
17121 ! write(*,*) 'enter collimateRHIC routine'
17122 if (c_material.eq.'BE') then
17123 mat = 1
17124 elseif (c_material.eq.'AL') then
17125 mat = 2
17126 elseif (c_material.eq.'CU') then
17127 mat = 3
17128 elseif (c_material.eq.'W') then
17129 mat = 4
17130 elseif (c_material.eq.'PB') then
17131 mat = 5
17132 elseif (c_material.eq.'C') then
17133 mat = 6
17134 elseif (c_material.eq.'C2') then
17135 mat = 7
17136 else
17137 write(*,*) 'ERR> Material not found. STOP (TW)', c_material
17138 ! STOP
17139 endif
17140 !
17141 length = c_length
17142 nev = np
17143 p0 = enom
17144 !
17145 !++ Initialize scattering processes
17146 !
17147 call scatin(p0)
17148
17149 ! EVENT LOOP, initial distribution is here a flat distribution with
17150 ! xmin=x-, xmax=x+, etc. from the input file
17151 !
17152 nhit = 0
17153 fracab = 0.
17154 mirror = 1.
17155 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
17156 do j = 1, nev
17157 !
17158 impact(j) = -1.
17159 lint(j) = -1.
17160 indiv(j) = -1.
17161 !
17162 x = x_in(j)
17163 xp = xp_in(j)
17164 z = y_in(j)
17165 zp = yp_in(j)
17166 p = p_in(j)
17167 ! sp = s_in(J)
17168 sp = 0.
17169 dpop = (p - p0)/p0
17170 !
17171 !++ Transform particle coordinates to get into collimator coordinate
17172 !++ system
17173 !
17174 !++ First check whether particle was lost before
17175 !
17176 ! if (x.lt.99.0*1e-3 .and. z.lt.99.0*1e-3) then
17177 if (x.lt.99.0*1d-3 .and. z.lt.99.0*1d-3) then
17178 !
17179 !++ First do rotation into collimator frame
17180 !
17181 !JUNE2005
17182 !JUNE2005 CHANGE TO MAKE THE RHIC TREATMENT EASIER...
17183 !JUNE2005
17184 !+if crlibm
17185 ! x = x_in(j)*cos_rn(c_rotation) +sin_rn(c_rotation)*y_in(j)
17186 !+ei
17187 !+if .not.crlibm
17188 ! x = x_in(j)*cos(c_rotation) +sin(c_rotation)*y_in(j)
17189 !+ei
17190 !+if crlibm
17191 ! z = y_in(j)*cos_rn(c_rotation) -sin_rn(c_rotation)*x_in(j)
17192 !+ei
17193 !+if .not.crlibm
17194 ! z = y_in(j)*cos(c_rotation) -sin(c_rotation)*x_in(j)
17195 !+ei
17196 !+if crlibm
17197 ! xp = xp_in(j)*cos_rn(c_rotation)+sin_rn(c_rotation)*yp_in(j)
17198 !+ei
17199 !+if .not.crlibm
17200 ! xp = xp_in(j)*cos(c_rotation)+sin(c_rotation)*yp_in(j)
17201 !+ei
17202 !+if crlibm
17203 ! zp = yp_in(j)*cos_rn(c_rotation)-sin_rn(c_rotation)*xp_in(j)
17204 !+ei
17205 !+if .not.crlibm
17206 ! zp = yp_in(j)*cos(c_rotation)-sin(c_rotation)*xp_in(j)
17207 !+ei
17208 x = -1d0*x_in(j)
17209 z = -1d0*y_in(j)
17210 xp = -1d0*xp_in(j)
17211 zp = -1d0*yp_in(j)
17212 !JUNE2005
17213 !
17214 !++ For one-sided collimators consider only positive X. For negative
17215 !++ X jump to the next particle
17216 !
17217 !GRD IF (ONESIDED .AND. X.LT.0) GOTO 777
17218 !JUNE2005 if (onesided .and. x.lt.0d0 .or. z.gt.0d0) goto 777
17219 if (onesided .and. (x.lt.0d0 .and. z.gt.0d0)) goto 777
17220 !
17221 !++ Now mirror at the horizontal axis for negative X offset
17222 !
17223 !GRD
17224 !GRD THIS WE HAVE TO COMMENT OUT IN CASE OF RHIC BECAUSE THERE ARE
17225 !GRD ONLY ONE-SIDED COLLIMATORS
17226 !GRD
17227 ! IF (X.LT.0) THEN
17228 ! MIRROR = -1.
17229 ! tiltangle = -1.*C_TILT(2)
17230 ! ELSE
17231 ! MIRROR = 1.
17232 tiltangle = c_tilt(1)
17233 ! ENDIF
17234 ! X = MIRROR * X
17235 ! XP = MIRROR * XP
17236 !GRD
17237 !
17238 !++ Shift with opening and offset
17239 !
17240 x = x - c_aperture/2 - mirror*c_offset
17241 !GRD
17242 !GRD SPECIAL FEATURE TO TAKE INTO ACCOUNT THE PARTICULAR SHAPE OF RHIC PRIMARY C
17243 !GRD
17244 !JUNE2005 HERE WE ADD THE ABILITY TO HAVE 2 DIFFERENT OPENINGS FOR THE TWO PLAN
17245 !JUNE2005 OF THE PRIMARY COLLIMATOR OF RHIC
17246 !JUNE2005
17247 ! z = z + c_aperture/2 + mirror*c_offset
17248 z = z + n_aperture/2 + mirror*c_offset
17249 !JUNE2005
17250 ! if(iturn.eq.1) &
17251 ! &write(*,*) 'check ',x,xp,z,zp,c_aperture,n_aperture
17252 !JUNE2005
17253 !
17254 !++ Include collimator tilt
17255 !
17256 if (tiltangle.gt.0.) then
17257 xp = xp - tiltangle
17258 elseif (tiltangle.lt.0.) then
17259 x = x + sin(tiltangle) * c_length
17260 xp = xp - tiltangle
17261 endif
17262 !
17263 !++ For selected collimator, first turn reset particle distribution
17264 !++ to simple pencil beam
17265 !
17266 nprim = 3
17267 if ( (icoll.eq.ipencil &
17268 &.and. iturn.eq.1) .or. &
17269 &(iturn.eq.1 .and. ipencil.eq.999 .and. &
17270 &icoll.le.nprim .and. &
17271 &(j.ge.(icoll-1)*nev/nprim) .and. &
17272 &(j.le.(icoll)*nev/nprim) &
17273 &) ) then
17274 x = pencil_dx(icoll)
17275 xp = 0.
17276 z = 0.
17277 zp = 0.
17278 dpop = 0.
17279 if(rndm4().lt.0.5) mirror = -abs(mirror)
17280 if(rndm4().ge.0.5) mirror = abs(mirror)
17281 endif
17282 !
17283 !++ particle passing above the jaw are discarded => take new event
17284 !++ entering by the face, shorten the length (zlm) and keep track of
17285 !++ entrance longitudinal coordinate (keeps) for histograms
17286 !
17287 !++ The definition is that the collimator jaw is at x>=0.
17288 !
17289 !++ 1) Check whether particle hits the collimator
17290 !
17291 hit = .false.
17292 s = 0.
17293 keeps = 0.
17294 zlm = -1.0d0 * length
17295 !
17296 !GRD
17297 !JUNE2005 if (x.ge.0d0 .and. z.le.0d0) then
17298 if (x.ge.0d0 .and. z.le.0d0) then
17299 goto 10
17300 !
17301 !++ Particle hits collimator and we assume interaction length ZLM equal
17302 !++ to collimator length (what if it would leave collimator after
17303 !++ small length due to angle???)
17304 !
17305 !JUNE2005
17306 ! zlm = length
17307 ! impact(j) = max(x,(-1d0*z))
17308 ! if(impact(j).eq.x) then
17309 ! indiv(j) = xp
17310 ! else
17311 ! indiv(j) = zp
17312 ! endif
17313 ! endif
17314 !JUNE2005
17315 !GRD
17316 !JUNE2005 if(x.lt.0d0.and.z.gt.0d0.and.xp.le.0d0.and.zp.ge.0d0) then
17317 elseif(x.lt.0d0.and.z.gt.0d0.and.xp.le.0d0 &
17318 &.and.zp.ge.0d0) then
17319 goto 20
17320 !GRD
17321 !JUNE2005 if(x.lt.0d0.and.z.gt.0d0.and.xp.le.0d0.and.zp.ge.0d0) then
17322 !
17323 !++ Particle does not hit collimator. Interaction length ZLM is zero.
17324 !
17325 !JUNE2005 zlm = 0.
17326 !JUNE2005 endif
17327 !GRD
17328 !JUNE2005 if (x.lt.0d0.and.z.gt.0d0.and.xp.gt.0d0.and.zp.ge.0d0) then
17329 !JUNE2005
17330 ! zlm = 0.
17331 ! endif
17332 !JUNE2005
17333 !
17334 !JUNE2005
17335 !JUNE2005 THAT WAS PIECE OF CAKE; NOW COMES THE TRICKY PART...
17336 !JUNE2005
17337 !JUNE2005 THE IDEA WOULD BE TO FIRST LIST ALL THE IMPACT
17338 !JUNE2005 POSSIBILITIES, THEN SEND VIA GOTO TO THE CORRECT
17339 !JUNE2005 TREATMENT
17340 !JUNE2005
17341 elseif((x.lt.0d0).and.(z.le.0d0)) then
17342 goto 100
17343 elseif((x.ge.0d0).and.(z.gt.0d0)) then
17344 goto 200
17345 elseif((x.lt.0d0).and.(xp.gt.0d0)) then
17346 goto 300
17347 elseif((z.gt.0d0).and.(zp.lt.0d0)) then
17348 goto 400
17349 endif
17350 !GRD
17351 10 continue
17352 event = 10
17353 zlm = length
17354 impact(j) = max(x,(-1d0*z))
17355 if(impact(j).eq.x) then
17356 indiv(j) = xp
17357 else
17358 indiv(j) = zp
17359 endif
17360 goto 999
17361 !GRD
17362 20 continue
17363 event = 20
17364 zlm = 0.
17365 goto 999
17366 !GRD
17367 100 continue
17368 event = 100
17369 zlm = length
17370 impact(j) = -1d0*z
17371 indiv(j) = zp
17372 goto 999
17373 !GRD
17374 200 continue
17375 event = 200
17376 zlm = length
17377 impact(j) = x
17378 indiv(j) = xp
17379 goto 999
17380 !GRD
17381 !JUNE2005
17382 !JUNE2005 HERE ONE HAS FIRST TO CHECK IF THERE'S NOT A HIT IN THE
17383 !JUNE2005 OTHER PLANE AT THE SAME TIME
17384 !JUNE2005
17385 300 continue
17386 event = 300
17387 if(z.gt.0d0.and.zp.lt.0d0) goto 500
17388 !
17389 !++ Calculate s-coordinate of interaction point
17390 !
17391 s = (-1.0d0*x) / xp
17392 if (s.le.0d0) then
17393 write(*,*) 'S.LE.0 -> This should not happen (1)'
17394 stop
17395 endif
17396 !
17397 if (s .lt. length) then
17398 zlm = length - s
17399 impact(j) = 0.
17400 indiv(j) = xp
17401 else
17402 zlm = 0.
17403 endif
17404 goto 999
17405 !GRD
17406 400 continue
17407 event = 400
17408 !JUNE2005 if (x.lt.0d0.and.z.gt.0d0.and.xp.le.0d0.and.zp.lt.0d0) then
17409 !
17410 !++ Calculate s-coordinate of interaction point
17411 !
17412 s = (-1.0d0*z) / zp
17413 if (s.le.0) then
17414 write(*,*) 'S.LE.0 -> This should not happen (2)'
17415 stop
17416 endif
17417 !
17418 if (s .lt. length) then
17419 zlm = length - s
17420 impact(j) = 0.
17421 indiv(j) = zp
17422 else
17423 zlm = 0.
17424 endif
17425 !JUNE2005 endif
17426 !GRD
17427 goto 999
17428 !GRD
17429 !GRD
17430 !JUNE2005 if (x.lt.0d0.and.z.gt.0d0.and.xp.gt.0d0.and.zp.lt.0d0) then
17431 500 continue
17432 event = 500
17433 !
17434 !++ Calculate s-coordinate of interaction point
17435 !
17436 sx = (-1.0d0*x) / xp
17437 sz = (-1.0d0*z) / zp
17438 !
17439 if(sx.lt.sz) s=sx
17440 if(sx.ge.sz) s=sz
17441 !
17442 if (s.le.0d0) then
17443 write(*,*) 'S.LE.0 -> This should not happen (3)'
17444 stop
17445 endif
17446 !
17447 if (s .lt. length) then
17448 zlm = length - s
17449 impact(j) = 0.
17450 if(s.eq.sx) then
17451 indiv(j) = xp
17452 else
17453 indiv(j) = zp
17454 endif
17455 else
17456 zlm = 0.
17457 endif
17458 !
17459 !JUNE2005 endif
17460 !GRD
17461 !GRD
17462 999 continue
17463 !JUNE2005
17464 ! write(*,*) 'event ',event,x,xp,z,zp
17465 ! if(impact(j).lt.0d0) then
17466 ! if(impact(j).ne.-1d0) &
17467 ! &write(*,*) 'argh! ',impact(j),x,xp,z,zp,s,event
17468 ! endif
17469 ! if(impact(j).ge.0d0) then
17470 ! write(*,*) 'impact! ',impact(j),x,xp,z,zp,s,event
17471 ! endif
17472 !JUNE2005
17473 !
17474 !++ First do the drift part
17475 !
17476 drift_length = length - zlm
17477 if (drift_length.gt.0.) then
17478 x = x + xp* drift_length
17479 z = z + zp * drift_length
17480 sp = sp + drift_length
17481 endif
17482 !
17483 !++ Now do the scattering part
17484 !
17485 if (zlm.gt.0.) then
17486 nhit = nhit + 1
17487 ! WRITE(*,*) J,X,XP,Z,ZP,SP,DPOP
17488 !DEBUG
17489 ! write(*,*) 'abs?',s,zlm
17490 !DEBUG
17491 !JUNE2005
17492 !JUNE2005 IN ORDER TO HAVE A PROPER TREATMENT IN THE CASE OF THE VERTICAL
17493 !JUNE2005 PLANE, CHANGE AGAIN THE FRAME FOR THE SCATTERING SUBROUTINES...
17494 !JUNE2005
17495 if(event.eq.100.or.event.eq.400) then
17496 !GRD first go back into normal frame...
17497 x = x + c_aperture/2 + mirror*c_offset
17498 z = z - n_aperture/2 - mirror*c_offset
17499 x = -1d0*x
17500 xp = -1d0*xp
17501 z = -1d0*z
17502 zp = -1d0*zp
17503 !GRD ...then do as for a vertical collimator
17504 x = z
17505 xp = zp
17506 z = -1d0*x
17507 zp = -1d0*x
17508 x = x - n_aperture/2 - mirror*c_offset
17509 z = z + c_aperture/2 + mirror*c_offset
17510 endif
17511 !JUNE2005
17512 call jaw(s, nabs)
17513 !DEBUG
17514 ! write(*,*) 'abs?',nabs
17515 !DEBUG
17516 !JUNE2005
17517 !JUNE2005 ...WITHOUT FORGETTING TO GO BACK TO THE "ORIGINAL" FRAME AFTER THE
17518 !JUNE2005 ROUTINES, SO AS TO AVOID RIDICULOUS VALUES FOR KICKS IN EITHER PLANE
17519 if(event.eq.100.or.event.eq.400) then
17520 !GRD first go back into normal frame...
17521 x = x + n_aperture/2 + mirror*c_offset
17522 z = z - c_aperture/2 - mirror*c_offset
17523 x = -1d0*z
17524 xp = -1d0*zp
17525 z = x
17526 zp = xp
17527 !GRD ...then go back to face the horizontal jaw at 180 degrees
17528 x = -1d0*x
17529 xp = -1d0*xp
17530 z = -1d0*z
17531 zp = -1d0*zp
17532 x = x - c_aperture/2 - mirror*c_offset
17533 z = z + n_aperture/2 + mirror*c_offset
17534 endif
17535 !JUNE2005
17536 lhit(j) = 10000*ie + iturn
17537 !
17538 !++ If particle is absorbed then set x and y to 99.99 mm
17539 !
17540 if (nabs.eq.1) then
17541 !APRIL2005
17542 !TO WRITE FLUKA INPUT CORRECTLY, WE HAVE TO GO BACK IN THE MACHINE FRAME
17543 if (tiltangle.gt.0.) then
17544 x = x + tiltangle*c_length
17545 xp = xp + tiltangle
17546 elseif (tiltangle.lt.0.) then
17547 x = x + tiltangle*c_length
17548 xp = xp + tiltangle
17549 !
17550 x = x - sin(tiltangle) * c_length
17551 endif
17552 !
17553 !++ Transform back to particle coordinates with opening and offset
17554 !
17555 x = x + c_aperture/2 + mirror*c_offset
17556 !GRD
17557 !JUNE2005 OF COURSE WE ADAPT ALSO THE PREVIOUS CHANGE WHEN SHIFTING BACK
17558 !JUNE2005 TO THE ACCELERATOR FRAME...
17559 ! z = z - c_aperture/2 - mirror*c_offset
17560 z = z - n_aperture/2 - mirror*c_offset
17561 !JUNE2005
17562 !
17563 !++ Last do rotation into collimator frame
17564 !
17565 x_flk = -1d0*x
17566 y_flk = -1d0*z
17567 xp_flk = -1d0*xp
17568 yp_flk = -1d0*zp
17569 !NOW WE CAN WRITE THE COORDINATES OF THE LOST PARTICLES
17570 if(dowrite_impact) then
17571 write(48,'(i4,(2x,f5.3),(2x,f8.6),4(1x,e16.7),2x,i2,2x,i5)') &
17572 &icoll,c_rotation,s+sp, &
17573 &x_flk*1d3, xp_flk*1d3, y_flk*1d3, yp_flk*1d3, &
17574 &nabs,name(j)
17575 endif
17576 !APRIL2005
17577 fracab = fracab + 1
17578 ! x = 99.99*1e-3
17579 ! z = 99.99*1e-3
17580 x = 99.99*1.0d-3
17581 z = 99.99*1.0d-3
17582 part_abs(j) = 10000*ie + iturn
17583 lint(j) = zlm
17584 endif
17585 endif
17586 !
17587 !++ Do the rest drift, if particle left collimator early
17588 !
17589 if (nabs.ne.1 .and. zlm.gt.0.) then
17590 drift_length = (length-(s+sp))
17591 ! if (drift_length.gt.1.e-15) then
17592 if (drift_length.gt.1.0d-15) then
17593 ! WRITE(*,*) J, DRIFT_LENGTH
17594 x = x + xp * drift_length
17595 z = z + zp * drift_length
17596 sp = sp + drift_length
17597 endif
17598 lint(j) = zlm - drift_length
17599 endif
17600 !
17601 !++ Transform back to particle coordinates with opening and offset
17602 !
17603 ! if (x.lt.99.0*1e-3 .and. z.lt.99.0*1e-3) then
17604 if (x.lt.99.0*1d-3 .and. z.lt.99.0*1d-3) then
17605 !
17606 !++ Include collimator tilt
17607 !
17608 if (tiltangle.gt.0.) then
17609 x = x + tiltangle*c_length
17610 xp = xp + tiltangle
17611 elseif (tiltangle.lt.0.) then
17612 x = x + tiltangle*c_length
17613 xp = xp + tiltangle
17614 !
17615 x = x - sin(tiltangle) * c_length
17616 endif
17617 !
17618 !++ Transform back to particle coordinates with opening and offset
17619 !
17620 z00 = z
17621 x00 = x + mirror*c_offset
17622 x = x + c_aperture/2 + mirror*c_offset
17623 !GRD
17624 !JUNE2005 OF COURSE WE ADAPT ALSO THE PREVIOUS CHANGE WHEN SHIFTING BACK
17625 !JUNE2005 TO THE ACCELERATOR FRAME...
17626 ! z = z - c_aperture/2 - mirror*c_offset
17627 z = z - n_aperture/2 - mirror*c_offset
17628 !JUNE2005
17629 !
17630 !++ Now mirror at the horizontal axis for negative X offset
17631 !
17632 x = mirror * x
17633 xp = mirror * xp
17634 !
17635 !++ Last do rotation into collimator frame
17636 !
17637 !JUNE2005
17638 !+if crlibm
17639 ! x_in(j) = x *cos_rn(-1.*c_rotation) + &
17640 !+ei
17641 !+if .not.crlibm
17642 ! x_in(j) = x *cos(-1.*c_rotation) + &
17643 !+ei
17644 !+if crlibm
17645 ! &z *sin_rn(-1.*c_rotation)
17646 !+ei
17647 !+if .not.crlibm
17648 ! &z *sin(-1.*c_rotation)
17649 !+ei
17650 !+if crlibm
17651 ! y_in(j) = z *cos_rn(-1.*c_rotation) - &
17652 !+ei
17653 !+if .not.crlibm
17654 ! y_in(j) = z *cos(-1.*c_rotation) - &
17655 !+ei
17656 !+if crlibm
17657 ! &x *sin_rn(-1.*c_rotation)
17658 !+ei
17659 !+if .not.crlibm
17660 ! &x *sin(-1.*c_rotation)
17661 !+ei
17662 !+if crlibm
17663 ! xp_in(j) = xp *cos_rn(-1.*c_rotation) + &
17664 !+ei
17665 !+if .not.crlibm
17666 ! xp_in(j) = xp *cos(-1.*c_rotation) + &
17667 !+ei
17668 !+if crlibm
17669 ! &zp *sin_rn(-1.*c_rotation)
17670 !+ei
17671 !+if .not.crlibm
17672 ! &zp *sin(-1.*c_rotation)
17673 !+ei
17674 !+if crlibm
17675 ! yp_in(j) = zp *cos_rn(-1.*c_rotation) - &
17676 !+ei
17677 !+if .not.crlibm
17678 ! yp_in(j) = zp *cos(-1.*c_rotation) - &
17679 !+ei
17680 !+if crlibm
17681 ! &xp *sin_rn(-1.*c_rotation)
17682 !+ei
17683 !+if .not.crlibm
17684 ! &xp *sin(-1.*c_rotation)
17685 !+ei
17686 x_in(j) = -1d0*x
17687 y_in(j) = -1d0*z
17688 xp_in(j) = -1d0*xp
17689 yp_in(j) = -1d0*zp
17690 !JUNE2005
17691 !
17692 if ( (icoll.eq.ipencil &
17693 &.and. iturn.eq.1) .or. &
17694 &(iturn.eq.1 .and. ipencil.eq.999 .and. &
17695 &icoll.le.nprim .and. &
17696 &(j.ge.(icoll-1)*nev/nprim) .and. &
17697 &(j.le.(icoll)*nev/nprim) &
17698 &) ) then
17699 !
17700 x00 = mirror * x00
17701 x_in(j) = x00 *cos(-1.*c_rotation) + &
17702 &z00 *sin(-1.*c_rotation)
17703 y_in(j) = z00 *cos(-1.*c_rotation) - &
17704 &x00 *sin(-1.*c_rotation)
17705 !
17706 xp_in(j) = xp_in(j) + mirror*xp_pencil0
17707 yp_in(j) = yp_in(j) + mirror*yp_pencil0
17708 x_in(j) = x_in(j) + mirror*x_pencil(icoll)
17709 y_in(j) = y_in(j) + mirror*y_pencil(icoll)
17710 endif
17711 !
17712 p_in(j) = (1 + dpop) * p0
17713 s_in(j) = s_in(j) + sp
17714 !
17715 else
17716 x_in(j) = x
17717 y_in(j) = z
17718 endif
17719 !
17720 !++ End of check for particles not being lost before
17721 !
17722 endif
17723 !
17724 ! IF (X.GT.99.00) WRITE(*,*) 'After : ', X, X_IN(J)
17725 !
17726 !++ End of loop over all particles
17727 !
17728 777 end do
17729 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
17730 !
17731 ! WRITE(*,*) 'Number of particles: ', Nev
17732 ! WRITE(*,*) 'Number of particle hits: ', Nhit
17733 ! WRITE(*,*) 'Number of absorped particles: ', fracab
17734 ! WRITE(*,*) 'Number of escaped particles: ', Nhit-fracab
17735 ! WRITE(*,*) 'Fraction of absorped particles: ', 100.*fracab/Nhit
17736 !
17737 end
17738 !
17739 !-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----
17740 !
17741 subroutine makedis(mynp, myalphax, myalphay, mybetax, mybetay, &
17742 &myemitx0, myemity0, myenom, mynex, mdex, myney, mdey, &
17743 &myx, myxp, myy, myyp, myp, mys)
17744 !
17745 ! Generate distribution
17746 !
17747 implicit none
17748 !
17749 integer max_ncoll,max_npart,maxn,numeff,outlun,nc
17750 !UPGRADE January 2005
17751 ! PARAMETER (MAX_NCOLL=68,MAX_NPART=20000,nc=32,NUMEFF=19,
17752 parameter (max_ncoll=100,max_npart=20000,nc=32,numeff=19, &
17753 &maxn=20000,outlun=54)
17754 !
17755 !++ Vectors of coordinates
17756 !
17757 logical cut_input
17758 integer i,j,mynp,nloop
17759 double precision myx(maxn),myxp(maxn),myy(maxn),myyp(maxn), &
17760 &myp(maxn),mys(maxn),myalphax,mybetax,myemitx0,myemitx,mynex,mdex, &
17761 &mygammax,myalphay,mybetay,myemity0,myemity,myney,mdey,mygammay, &
17762 &xsigmax,ysigmay,myenom,nr,ndr
17763 !
17764 !
17765 real rndm4
17766 !
17767 !
17768 character*80 dummy
17769 !
17770 !
17771 common /cut/ cut_input
17772 !
17773 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
17774 !
17775 double precision pi
17776 !
17777 save
17778 !-----------------------------------------------------------------------
17779 !++ Generate particle distribution
17780 !
17781 !
17782 !++ Generate random distribution, assuming optical parameters at IP1
17783 !
17784 !
17785 !++ Calculate the gammas
17786 !
17787 pi=4d0*atan(1d0)
17788 mygammax = (1d0+myalphax**2)/mybetax
17789 mygammay = (1d0+myalphay**2)/mybetay
17790 !++TW 11/07 reset j, helps if subroutine is called twice
17791 ! was done during try to reset distribution, still needed
17792 ! will this subroutine ever called twice?
17793 j = 0
17794 !
17795 !
17796 !++ Number of points and generate distribution
17797 !
17798 write(*,*)
17799 write(*,*) 'Generation of particle distribution Version 1'
17800 write(*,*)
17801 write(*,*) 'This routine generates particles in phase space'
17802 write(*,*) 'X/XP and Y/YP ellipses, as defined in the input'
17803 write(*,*) 'parameters. Distribution is flat in the band.'
17804 write(*,*) 'X and Y are fully uncorrelated.'
17805 write(*,*)
17806 !
17807 write(outlun,*)
17808 write(outlun,*) 'Generation of particle distribution Version 1'
17809 write(outlun,*)
17810 write(outlun,*) 'This routine generates particles in phase space'
17811 write(outlun,*) 'X/XP and Y/YP ellipses, as defined in the input'
17812 write(outlun,*) 'parameters. Distribution is flat in the band.'
17813 write(outlun,*) 'X and Y are fully uncorrelated.'
17814 write(outlun,*)
17815 write(outlun,*) 'INFO> Number of particles = ', mynp
17816 write(outlun,*) 'INFO> Av number of x sigmas = ', mynex
17817 write(outlun,*) 'INFO> +- spread in x sigmas = ', mdex
17818 write(outlun,*) 'I0NFO> Av number of y sigmas = ', myney
17819 write(outlun,*) 'INFO> +- spread in y sigmas = ', mdey
17820 write(outlun,*) 'INFO> Nominal beam energy = ', myenom
17821 write(outlun,*) 'INFO> Sigma_x0 = ', sqrt(mybetax*myemitx0)
17822 write(outlun,*) 'INFO> Sigma_y0 = ', sqrt(mybetay*myemity0)
17823 write(outlun,*) 'INFO> Beta x = ', mybetax
17824 write(outlun,*) 'INFO> Beta y = ', mybetay
17825 write(outlun,*) 'INFO> Alpha x = ', myalphax
17826 write(outlun,*) 'INFO> Alpha y = ', myalphay
17827 write(outlun,*) 'INFO> DISP x = '
17828 write(outlun,*) 'INFO> DISP y = '
17829 !
17830 do while (j.lt.mynp)
17831 !
17832 j = j + 1
17833 myemitx = myemitx0*(mynex + (2d0*dble(rndm4()-0.5)*mdex) )**2
17834 xsigmax = sqrt(mybetax*myemitx)
17835 myx(j) = xsigmax * sin(2d0*pi*rndm4())
17836 if (rndm4().gt.0.5) then
17837 myxp(j) = sqrt(myemitx/mybetax-myx(j)**2/mybetax**2)- &
17838 &myalphax*myx(j)/mybetax
17839 else
17840 myxp(j) = -1*sqrt(myemitx/mybetax-myx(j)**2/mybetax**2)- &
17841 &myalphax*myx(j)/mybetax
17842 endif
17843 !
17844 myemity = myemity0*(myney + (2d0*dble(rndm4()-0.5)*mdey) )**2
17845 ysigmay = sqrt(mybetay*myemity)
17846 myy(j) = ysigmay * sin(2d0*pi*rndm4())
17847 if (rndm4().gt.0.5) then
17848 myyp(j) = sqrt(myemity/mybetay-myy(j)**2/mybetay**2)- &
17849 &myalphay*myy(j)/mybetay
17850 else
17851 myyp(j) = -1*sqrt(myemity/mybetay-myy(j)**2/mybetay**2)- &
17852 &myalphay*myy(j)/mybetay
17853 endif
17854 !
17855 !APRIL2005 TEST FOR FATS FLAG
17856 myp(j) = myenom
17857 ! if(j.eq.1) then
17858 ! myp(j) = myenom*(1-0.01)
17859 !! do j=2,mynp
17860 ! else
17861 ! myp(j) = myp(1) + (j-1)*2d0*0.01*myenom/(mynp-1)
17862 ! endif
17863 !APRIL2005 END OF TEST SECTION
17864 mys(j) = 0d0
17865 !
17866 !++ Dangerous stuff, just for the moment
17867 !
17868 if (cut_input) then
17869 if ( (.not. (myy(j).lt.-.008d-3 .and. myyp(j).lt.0.1d-3 .and. &
17870 &myyp(j).gt.0d0) ) .and. &
17871 &(.not. (myy(j).gt..008d-3 .and. myyp(j).gt.-0.1d-3 .and. &
17872 &myyp(j).lt.0d0) ) ) then
17873 j = j - 1
17874 endif
17875 endif
17876 !
17877 end do
17878 !
17879 return
17880 end
17881 !
17882 !========================================================================
17883 !
17884 ! SR, 08-05-2005: Add the finite beam size in the other dimension
17885 subroutine makedis_st(mynp, myalphax, myalphay, mybetax, mybetay, &
17886 & myemitx0, myemity0, myenom, mynex, mdex, myney, mdey, &
17887 & myx, myxp, myy, myyp, myp, mys)
17888
17889 ! Uses the old routine 'MAKEDIS' for the halo plane and adds the
17890 ! transverse beam size in the other plane (matched distrubutions
17891 ! are generated starting from thetwiss functions).
17892 ! If 'mynex' and 'myney' are BOTH set to zero, nominal bunches
17893 ! centred in the aperture centre are generated. (SR, 08-05-2005)
17894 !
17895 implicit none
17896 !
17897 integer max_ncoll,max_npart,maxn,numeff,outlun,nc
17898 !UPGRADE January 2005
17899 ! PARAMETER (MAX_NCOLL=68,MAX_NPART=20000,nc=32,NUMEFF=19,
17900 parameter (max_ncoll=100,max_npart=20000,nc=32,numeff=19, &
17901 &maxn=20000,outlun=54)
17902 !
17903 !++ Vectors of coordinates
17904 !
17905 logical cut_input
17906 integer i,j,mynp,nloop
17907 double precision myx(maxn),myxp(maxn),myy(maxn),myyp(maxn), &
17908 &myp(maxn),mys(maxn),myalphax,mybetax,myemitx0,myemitx,mynex,mdex, &
17909 &mygammax,myalphay,mybetay,myemity0,myemity,myney,mdey,mygammay, &
17910 &xsigmax,ysigmay,myenom,nr,ndr
17911 !
17912 !
17913 real rndm4
17914 !
17915 !
17916 character*80 dummy
17917 !
17918 !
17919 common /cut/ cut_input
17920 !
17921 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
17922 !
17923 double precision pi
17924 !
17925 double precision iix, iiy, phix, phiy
17926 !
17927 save
17928 !
17929 !-----------------------------------------------------------------------
17930 !++ Generate particle distribution
17931 !
17932 !
17933 !++ Generate random distribution, assuming optical parameters at IP1
17934 !
17935 !++ Calculate the gammas
17936 !
17937 write(*,*) ' New routine to add the finite beam size in the'
17938 write(*,*) ' other dimension (SR, 08-06-2005).'
17939
17940 pi=4d0*atan(1d0)
17941 !
17942 mygammax = (1d0+myalphax**2)/mybetax
17943 mygammay = (1d0+myalphay**2)/mybetay
17944 !
17945 do j=1, mynp
17946 if ((mynex.gt.0d0).and.(myney.eq.0d0)) then
17947 myemitx = myemitx0*(mynex+(2d0*dble(rndm4()-0.5)*mdex))**2
17948 xsigmax = sqrt(mybetax*myemitx)
17949 myx(j) = xsigmax * sin(2d0*pi*rndm4())
17950 if (rndm4().gt.0.5) then
17951 myxp(j) = sqrt(myemitx/mybetax-myx(j)**2/mybetax**2)- &
17952 & myalphax*myx(j)/mybetax
17953 else
17954 myxp(j) = -1d0*sqrt(myemitx/mybetax-myx(j)**2/mybetax**2)-&
17955 & myalphax*myx(j)/mybetax
17956 endif
17957 !
17958 phiy = 2*pi*rndm4()
17959 !
17960 iiy = -1d0*myemity0 * log( rndm4() )
17961 !
17962 myy(j) = sqrt(2*iiy*mybetay) * cos(phiy)
17963 myyp(j) = -1d0*sqrt(2*iiy/mybetay) * (sin(phiy) + &
17964 & myalphay * cos(phiy))
17965 elseif ( mynex.eq.0.and.myney.gt.0 ) then
17966 myemity = myemity0*(myney+(2d0*dble(rndm4()-0.5)*mdey))**2
17967 ysigmay = sqrt(mybetay*myemity)
17968 myy(j) = ysigmay * sin(2d0*pi*rndm4())
17969 if (rndm4().gt.0.5) then
17970 myyp(j) = sqrt(myemity/mybetay-myy(j)**2/mybetay**2)- &
17971 & myalphay*myy(j)/mybetay
17972 else
17973 myyp(j) = -1d0*sqrt(myemity/mybetay-myy(j)**2/mybetay**2)-&
17974 & myalphay*myy(j)/mybetay
17975 endif
17976 !
17977 phix = 2*pi*rndm4()
17978 iix = - myemitx0 * log( rndm4() )
17979 !
17980 myx(j) = sqrt(2*iix*mybetax) * cos(phix)
17981 myxp(j) = -1d0*sqrt(2*iix/mybetax) * (sin(phix) + &
17982 & myalphax * cos(phix))
17983 elseif ( mynex.eq.0.and.myney.eq.0 ) then
17984 phix = 2*pi*rndm4()
17985 iix = - myemitx0 * log( rndm4() )
17986 !
17987 myx(j) = sqrt(2*iix*mybetax) * cos(phix)
17988 myxp(j) = -1d0*sqrt(2*iix/mybetax) * (sin(phix) + &
17989 & myalphax * cos(phix))
17990 phiy = 2*pi*rndm4()
17991 iiy = - myemity0 * log( rndm4() )
17992 !
17993 myy(j) = sqrt(2*iiy*mybetay) * cos(phiy)
17994 myyp(j) = -1d0*sqrt(2*iiy/mybetay) * (sin(phiy) + &
17995 & myalphay * cos(phiy))
17996 else
17997 write(*,*) "Error - beam parameters not correctly set!"
17998 endif
17999 !
18000 myp(j) = myenom
18001 mys(j) = 0d0
18002 !
18003 end do
18004 !
18005 return
18006 end
18007 !
18008 !========================================================================
18009 !
18010 ! SR, 09-05-2005: Add the energy spread and the finite bunch length.
18011 ! Gaussian distributions assumed
18012 subroutine makedis_de(mynp, myalphax, myalphay, mybetax, mybetay, &
18013 & myemitx0, myemity0, myenom, mynex, mdex, myney, mdey, &
18014 & myx, myxp, myy, myyp, myp, mys, &
18015 & enerror,bunchlength)
18016
18017 ! Uses the old routine 'MAKEDIS' for the halo plane and adds the
18018 ! transverse beam size in the other plane (matched distrubutions
18019 ! are generated starting from thetwiss functions).
18020 ! If 'mynex' and 'myney' are BOTH set to zero, nominal bunches
18021 ! centred in the aperture centre are generated. (SR, 08-05-2005)
18022 implicit none
18023 !
18024 integer max_ncoll,max_npart,maxn,numeff,outlun,nc
18025 !UPGRADE January 2005
18026 ! PARAMETER (MAX_NCOLL=68,MAX_NPART=20000,nc=32,NUMEFF=19,
18027 parameter (max_ncoll=100,max_npart=20000,nc=32,numeff=19, &
18028 &maxn=20000,outlun=54)
18029 !
18030 !++ Vectors of coordinates
18031 !
18032 logical cut_input
18033 integer i,j,mynp,nloop
18034 double precision myx(maxn),myxp(maxn),myy(maxn),myyp(maxn), &
18035 &myp(maxn),mys(maxn),myalphax,mybetax,myemitx0,myemitx,mynex,mdex, &
18036 &mygammax,myalphay,mybetay,myemity0,myemity,myney,mdey,mygammay, &
18037 &xsigmax,ysigmay,myenom,nr,ndr
18038 !
18039 !
18040 real rndm4
18041 !
18042 !
18043 character*80 dummy
18044 !
18045 !
18046 common /cut/ cut_input
18047 !
18048 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
18049 !
18050 double precision pi
18051 !
18052 double precision ran_gauss
18053 double precision iix, iiy, phix, phiy
18054 double precision enerror, bunchlength
18055 double precision en_error, bunch_length
18056 !
18057 double precision long_cut
18058 double precision a_st, b_st
18059 !
18060 save
18061 !-----------------------------------------------------------------------
18062 !++ Generate particle distribution
18063 !
18064 !
18065 !++ Generate random distribution, assuming optical parameters at IP1
18066 !
18067 !++ Calculate the gammas
18068 pi=4d0*atan(1d0)
18069 !
18070 mygammax = (1d0+myalphax**2)/mybetax
18071 mygammay = (1d0+myalphay**2)/mybetay
18072
18073 ! Assign bunch length and dp/p depending on the energy
18074 ! Check if the units in metres are correct!
18075 !GRD if ( myenom.eq.7e6 ) then
18076 !GRD en_error = 1.129e-4
18077 !GRD bunch_length = 7.55e-2
18078 !GRD elseif ( myenom.eq.4.5e5 ) then
18079 !GRD en_error = 3.06e-4
18080 !GRD bunch_length = 11.24e-2
18081 !GRD else
18082 en_error = enerror
18083 bunch_length = bunchlength
18084 !GRD write(*,*)"Warning-Energy different from LHC inj or top!"
18085 !GRD write(*,*)" => 7TeV values of dp/p and bunch length used!"
18086 !GRD endif
18087 !GRD
18088 write (*,*) "Generation of bunch with dp/p and length:"
18089 write (*,*) " RMS bunch length = ", bunch_length
18090 write (*,*) " RMS energy spread = ", en_error
18091 do j=1, mynp
18092 if ((mynex.gt.0d0).and.(myney.eq.0d0)) then
18093 myemitx = myemitx0*(mynex+(2d0*dble(rndm4()-0.5)*mdex))**2
18094 xsigmax = sqrt(mybetax*myemitx)
18095 myx(j) = xsigmax * sin(2d0*pi*rndm4())
18096 if (rndm4().gt.0.5) then
18097 myxp(j) = sqrt(myemitx/mybetax-myx(j)**2/mybetax**2)- &
18098 & myalphax*myx(j)/mybetax
18099 else
18100 myxp(j) = -1d0*sqrt(myemitx/mybetax-myx(j)**2/mybetax**2)-&
18101 & myalphax*myx(j)/mybetax
18102 endif
18103 !
18104 phiy = 2*pi*rndm4()
18105 !
18106 iiy = -1d0*myemity0 * log( rndm4() )
18107 !
18108 myy(j) = sqrt(2*iiy*mybetay) * cos(phiy)
18109 myyp(j) = -1d0*sqrt(2*iiy/mybetay) * (sin(phiy) + &
18110 & myalphay * cos(phiy))
18111 elseif ( mynex.eq.0.and.myney.gt.0 ) then
18112 myemity = myemity0*(myney+(2d0*dble(rndm4()-0.5)*mdey))**2
18113 ysigmay = sqrt(mybetay*myemity)
18114 myy(j) = ysigmay * sin(2d0*pi*rndm4())
18115 if (rndm4().gt.0.5) then
18116 myyp(j) = sqrt(myemity/mybetay-myy(j)**2/mybetay**2)- &
18117 & myalphay*myy(j)/mybetay
18118 else
18119 myyp(j) = -1d0*sqrt(myemity/mybetay-myy(j)**2/mybetay**2)-&
18120 & myalphay*myy(j)/mybetay
18121 endif
18122 !
18123 phix = 2*pi*rndm4()
18124 iix = - myemitx0 * log( rndm4() )
18125 !
18126 myx(j) = sqrt(2*iix*mybetax) * cos(phix)
18127 myxp(j) = -1d0*sqrt(2*iix/mybetax) * (sin(phix) + &
18128 & myalphax * cos(phix))
18129 elseif ( mynex.eq.0.and.myney.eq.0 ) then
18130 phix = 2*pi*rndm4()
18131 iix = - myemitx0 * log( rndm4() )
18132 !
18133 myx(j) = sqrt(2*iix*mybetax) * cos(phix)
18134 myxp(j) = -1d0*sqrt(2*iix/mybetax) * (sin(phix) + &
18135 & myalphax * cos(phix))
18136 phiy = 2*pi*rndm4()
18137 iiy = - myemity0 * log( rndm4() )
18138 !
18139 myy(j) = sqrt(2*iiy*mybetay) * cos(phiy)
18140 myyp(j) = -1d0*sqrt(2*iiy/mybetay) * (sin(phiy) + &
18141 & myalphay * cos(phiy))
18142 else
18143 write(*,*) "Error - beam parameters not correctly set!"
18144 endif
18145 !
18146 end do
18147 ! SR, 11-08-2005 For longitudinal phase-space, add a cut at 2 sigma
18148 !++ 1st: generate mynpnumbers within the chose cut
18149 long_cut = 2
18150 j = 1
18151 do while (j.le.mynp)
18152 a_st = ran_gauss(5d0)
18153 b_st = ran_gauss(5d0)
18154 do while ((a_st*a_st+b_st*b_st).gt.long_cut*long_cut)
18155 a_st = ran_gauss(5d0)
18156 b_st = ran_gauss(5d0)
18157 enddo
18158 mys(j) = a_st
18159 myp(j) = b_st
18160 j = j + 1
18161 enddo
18162 !++ 2nd: give the correct values
18163 do j=1,mynp
18164 myp(j) = myenom * (1d0 + myp(j) * en_error)
18165 mys(j) = bunch_length * mys(j)
18166 enddo
18167 !
18168 return
18169 end
18170 !
18171 !========================================================================
18172 !
18173 subroutine readdis(filename_dis, mynp,
18174 & myx, myxp, myy, myyp, myp, mys)
18175 !
18176 ! SR, 09-08-2005
18177 ! Format for the input file:
18178 ! x, y -> [ m ]
18179 ! xp, yp -> [ rad ]
18180 ! s -> [ mm ]
18181 ! DE -> [ MeV ]
18182 !
18183 implicit none
18184
18185 integer max_ncoll,max_npart,maxn,numeff,outlun,nc
18186 !UPGRADE January 2005
18187 ! PARAMETER (MAX_NCOLL=68,MAX_NPART=20000,nc=32,NUMEFF=19,
18188 parameter (max_ncoll=100,max_npart=20000,nc=32,numeff=19, &
18189 &maxn=20000,outlun=54)
18190 !
18191 !++ Vectors of coordinates
18192 !
18193 logical cut_input
18194 integer i,j,mynp,nloop
18195 double precision myx(maxn),myxp(maxn),myy(maxn),myyp(maxn), &
18196 &myp(maxn),mys(maxn),myalphax,mybetax,myemitx0,myemitx,mynex,mdex, &
18197 &mygammax,myalphay,mybetay,myemity0,myemity,myney,mdey,mygammay, &
18198 &xsigmax,ysigmay,myenom,nr,ndr
18199 !
18200 !
18201 real rndm4
18202 !
18203 !
18204 character*80 dummy
18205 !
18206 !
18207 common /cut/ cut_input
18208 !
18209 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
18210 !
18211
18212 character*80 filename_dis
18213
18214 save
18215
18216 write(*,*) "Reading input bunch from ", filename_dis
18217
18218 open(unit=111, file=filename_dis)
18219
18220 do j=1,mynp
18221 read(111,*,end=10) myx(j), myxp(j), myy(j), myyp(j),
18222 & mys(j), myp(j)
18223 enddo
18224
18225 10 mynp = j - 1
18226 write(*,*) "Number of particles in the bunch = ",mynp
18227
18228 close(111)
18229
18230 return
18231 end
18232 !
18233 !========================================================================
18234 !
18235 subroutine makedis_radial(mynp, myalphax, myalphay, mybetax, &
18236 &mybetay, myemitx0, myemity0, myenom, nr, ndr,myx, myxp, myy, &
18237 &myyp, myp, mys)
18238 !
18239 implicit none
18240 !
18241 integer max_ncoll,max_npart,maxn,numeff,outlun,nc
18242 !UPGRADE January 2005
18243 ! PARAMETER (MAX_NCOLL=68,MAX_NPART=20000,nc=32,NUMEFF=19,
18244 parameter (max_ncoll=100,max_npart=20000,nc=32,numeff=19, &
18245 &maxn=20000,outlun=54)
18246 !
18247 !++ Vectors of coordinates
18248 !
18249 logical cut_input
18250 integer i,j,mynp,nloop
18251 double precision myx(maxn),myxp(maxn),myy(maxn),myyp(maxn), &
18252 &myp(maxn),mys(maxn),myalphax,mybetax,myemitx0,myemitx,mynex,mdex, &
18253 &mygammax,myalphay,mybetay,myemity0,myemity,myney,mdey,mygammay, &
18254 &xsigmax,ysigmay,myenom,nr,ndr
18255 !
18256 !
18257 real rndm4
18258 !
18259 !
18260 character*80 dummy
18261 !
18262 !
18263 common /cut/ cut_input
18264 !
18265 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
18266 !
18267 double precision pi
18268 !
18269 save
18270 !-----------------------------------------------------------------------
18271 !++ Generate particle distribution
18272 !
18273 !
18274 !++ Generate random distribution, assuming optical parameters at IP1
18275 !
18276 !++ Calculate the gammas
18277 !
18278 pi=4d0*atan(1d0)
18279 mygammax = (1d0+myalphax**2)/mybetax
18280 mygammay = (1d0+myalphay**2)/mybetay
18281 !
18282 !++ Number of points and generate distribution
18283 !
18284 mynex = nr/sqrt(2d0)
18285 mdex = ndr/sqrt(2d0)
18286 myney = nr/sqrt(2d0)
18287 mdey = ndr/sqrt(2d0)
18288 !
18289 write(*,*)
18290 write(*,*) 'Generation of particle distribution Version 2'
18291 write(*,*)
18292 write(*,*) 'This routine generates particles in that are fully'
18293 write(*,*) 'correlated between X and Y.'
18294 write(*,*)
18295 !
18296 write(outlun,*)
18297 write(outlun,*) 'Generation of particle distribution Version 2'
18298 write(outlun,*)
18299 write(outlun,*) &
18300 &'This routine generates particles in that are fully'
18301 write(outlun,*) 'correlated between X and Y.'
18302 write(outlun,*)
18303 write(outlun,*)
18304 write(outlun,*) 'INFO> Number of particles = ', mynp
18305 write(outlun,*) 'INFO> Av number of x sigmas = ', mynex
18306 write(outlun,*) 'INFO> +- spread in x sigmas = ', mdex
18307 write(outlun,*) 'INFO> Av number of y sigmas = ', myney
18308 write(outlun,*) 'INFO> +- spread in y sigmas = ', mdey
18309 write(outlun,*) 'INFO> Nominal beam energy = ', myenom
18310 write(outlun,*) 'INFO> Sigma_x0 = ', sqrt(mybetax*myemitx0)
18311 write(outlun,*) 'INFO> Sigma_y0 = ', sqrt(mybetay*myemity0)
18312 write(outlun,*)
18313 !
18314 do while (j.lt.mynp)
18315 !
18316 j = j + 1
18317 myemitx = myemitx0*(mynex + (2d0*dble(rndm4()-0.5)*mdex) )**2
18318 xsigmax = sqrt(mybetax*myemitx)
18319 myx(j) = xsigmax * sin(2d0*pi*rndm4())
18320 if (rndm4().gt.0.5) then
18321 myxp(j) = sqrt(myemitx/mybetax-myx(j)**2/mybetax**2)- &
18322 &myalphax*myx(j)/mybetax
18323 else
18324 myxp(j) = -1*sqrt(myemitx/mybetax-myx(j)**2/mybetax**2)- &
18325 &myalphax*myx(j)/mybetax
18326 endif
18327 !
18328 myemity = myemity0*(myney + (2d0*dble(rndm4()-0.5)*mdey) )**2
18329 ysigmay = sqrt(mybetay*myemity)
18330 myy(j) = ysigmay * sin(2d0*pi*rndm4())
18331 if (rndm4().gt.0.5) then
18332 myyp(j) = sqrt(myemity/mybetay-myy(j)**2/mybetay**2)- &
18333 &myalphay*myy(j)/mybetay
18334 else
18335 myyp(j) = -1*sqrt(myemity/mybetay-myy(j)**2/mybetay**2)- &
18336 &myalphay*myy(j)/mybetay
18337 endif
18338 !
18339 !APRIL2005
18340 myp(j) = myenom
18341 ! if(j.eq.1) then
18342 ! myp(j) = myenom*(1-0.05)
18343 !! do j=2,mynp
18344 ! else
18345 ! myp(j) = myp(1) + (j-1)*2d0*0.05*myenom/(mynp-1)
18346 ! endif
18347 !APRIL2005
18348 mys(j) = 0d0
18349 !
18350 !++ Dangerous stuff, just for the moment
18351 !
18352 ! IF ( (.NOT. (Y(j).LT.-.008e-3 .AND. YP(j).LT.0.1e-3 .AND.
18353 ! 1 YP(j).GT.0.0) ) .AND.
18354 ! 2 (.NOT. (Y(j).GT..008e-3 .AND. YP(j).GT.-0.1e-3 .AND.
18355 ! 3 YP(j).LT.0.0) ) ) THEN
18356 ! J = J - 1
18357 ! ENDIF
18358 !
18359 end do
18360 !
18361 return
18362 end
18363 !
18364 !-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----
18365 !
18366 function ichoix(ma)
18367 implicit none
18368 integer nrmat,nmat,mat,irmat,mcurr
18369 ! parameter(nmat=12,nrmat=5)
18370 parameter(nmat=12,nrmat=7)
18371 double precision xintl,radl,x,xp,z,zp,dpop,p0,zlm,zlm1,xpsd,zpsd, &
18372 &psd,dpodx(nmat),anuc,rho,emr,tlcut,hcut,cs,csref,bnref,freep, &
18373 &cprob,bn,bpp,xln15s,ecmsq,pptot,ppel,ppsd,pptref,pperef,pref, &
18374 &pptco,ppeco,sdcoe,freeco,fnavo,zatom
18375 parameter(fnavo=6.02e23)
18376 real cgen
18377 character * 4 mname(nmat)
18378 common/mater/anuc(nmat),zatom(nmat),rho(nmat),emr(nmat),irmat
18379 common/coul/tlcut,hcut(nmat),cgen(200,nmat),mcurr
18380 common/scat/cs(0:5,nmat),csref(0:5,nmat),bnref(nmat),freep(nmat)
18381 common/scatu/cprob(0:5,nmat),bn(nmat),bpp,xln15s,ecmsq
18382 common/scatu2/xintl(nmat),radl(nmat),mname
18383 common/scatpp/pptot,ppel,ppsd
18384 common/sppref/pptref,pperef,pref,pptco,ppeco,sdcoe,freeco
18385 common/phase/x,xp,z,zp,dpop
18386 common/nommom/p0
18387 common/cjaw1/zlm
18388 common/cmcs1/zlm1
18389 common/materia/mat
18390 common/sindif/xpsd,zpsd,psd
18391 common/cdpodx/dpodx
18392 integer ma,i,ichoix
18393 double precision aran
18394 real rndm4
18395 aran=dble(rndm4())
18396 i=1
18397 10 if ( aran.gt.cprob(i,ma) ) then
18398 i=i+1
18399 goto 10
18400 endif
18401 ichoix=i
18402 return
18403 end
18404 !---------------------------------------------------------------
18405 !
18406 function gettran(inter,xmat,p)
18407 !
18408 !++ This function determines: GETTRAN - rms transverse momentum transfer
18409 !
18410 !++ Note: For single-diffractive scattering the vector p of momentum
18411 !++ is modified (energy loss is applied)
18412 !
18413 implicit none
18414 integer nrmat,nmat,mat,irmat,mcurr
18415 ! parameter(nmat=12,nrmat=5)
18416 parameter(nmat=12,nrmat=7)
18417 double precision xintl,radl,x,xp,z,zp,dpop,p0,zlm,zlm1,xpsd,zpsd, &
18418 &psd,dpodx(nmat),anuc,rho,emr,tlcut,hcut,cs,csref,bnref,freep, &
18419 &cprob,bn,bpp,xln15s,ecmsq,pptot,ppel,ppsd,pptref,pperef,pref, &
18420 &pptco,ppeco,sdcoe,freeco,fnavo,zatom
18421 parameter(fnavo=6.02e23)
18422 real cgen
18423 character * 4 mname(nmat)
18424 common/mater/anuc(nmat),zatom(nmat),rho(nmat),emr(nmat),irmat
18425 common/coul/tlcut,hcut(nmat),cgen(200,nmat),mcurr
18426 common/scat/cs(0:5,nmat),csref(0:5,nmat),bnref(nmat),freep(nmat)
18427 common/scatu/cprob(0:5,nmat),bn(nmat),bpp,xln15s,ecmsq
18428 common/scatu2/xintl(nmat),radl(nmat),mname
18429 common/scatpp/pptot,ppel,ppsd
18430 common/sppref/pptref,pperef,pref,pptco,ppeco,sdcoe,freeco
18431 common/phase/x,xp,z,zp,dpop
18432 common/nommom/p0
18433 common/cjaw1/zlm
18434 common/cmcs1/zlm1
18435 common/materia/mat
18436 common/sindif/xpsd,zpsd,psd
18437 common/cdpodx/dpodx
18438 integer inter,length,xmat
18439 double precision p,gettran,t,xm2,bsd
18440 real rndm4,truth,xran(1)
18441 !
18442 ! inter=2: Nuclear Elastic, 3: pp Elastic, 4: Single Diffractif, 5:Coulomb
18443 !
18444 if ( inter.eq.2 ) then
18445 gettran = -log(dble(rndm4()))/bn(xmat)
18446 !
18447 elseif ( inter .eq. 3 ) then
18448 gettran = -log(dble(rndm4()))/bpp
18449 !
18450 elseif ( inter .eq. 4 ) then
18451 xm2 = exp( dble(rndm4()) * xln15s )
18452 p = p *(1.d0 - xm2/ecmsq)
18453 if ( xm2 .lt. 2.d0 ) then
18454 bsd = 2.d0 * bpp
18455 elseif (( xm2 .ge. 2.d0 ).and. ( xm2 .le. 5.d0 )) then
18456 bsd = (106.d0-17.d0*xm2) * bpp / 26.d0
18457 elseif ( xm2 .gt. 5.d0 ) then
18458 bsd = 7.d0 * bpp / 12.d0
18459 endif
18460 gettran = -log(dble(rndm4()))/bsd
18461 !
18462 elseif ( inter.eq.5 ) then
18463 length=1
18464 call funlux( cgen(1,mat) , xran, length)
18465 truth=xran(1)
18466 t=truth
18467 gettran = t
18468 endif
18469 return
18470 end
18471 !---------------------------------------------------------------
18472 !
18473 subroutine tetat(t,p,tx,tz)
18474 implicit none
18475 double precision t,p,tx,tz,va,vb,va2,vb2,r2,teta
18476 real rndm4
18477 teta = sqrt(t)/p
18478 ! Generate sine and cosine of an angle uniform in [0,2pi](see RPP)
18479 10 va =2d0*rndm4()-1d0
18480 vb = dble(rndm4())
18481 va2 = va*va
18482 vb2 = vb*vb
18483 r2 = va2 + vb2
18484 if ( r2.gt.1.d0) go to 10
18485 tx = teta * (2.d0*va*vb) / r2
18486 tz = teta * (va2 - vb2) / r2
18487 return
18488 end
18489 !---------------------------------------------------------------
18490 !
18491 function ruth(t)
18492 implicit none
18493 integer nrmat,nmat,mat,irmat,mcurr
18494 ! parameter(nmat=12,nrmat=5)
18495 parameter(nmat=12,nrmat=7)
18496 double precision xintl,radl,x,xp,z,zp,dpop,p0,zlm,zlm1,xpsd,zpsd, &
18497 &psd,dpodx(nmat),anuc,rho,emr,tlcut,hcut,cs,csref,bnref,freep, &
18498 &cprob,bn,bpp,xln15s,ecmsq,pptot,ppel,ppsd,pptref,pperef,pref, &
18499 &pptco,ppeco,sdcoe,freeco,fnavo,zatom
18500 parameter(fnavo=6.02e23)
18501 real cgen
18502 character * 4 mname(nmat)
18503 common/mater/anuc(nmat),zatom(nmat),rho(nmat),emr(nmat),irmat
18504 common/coul/tlcut,hcut(nmat),cgen(200,nmat),mcurr
18505 common/scat/cs(0:5,nmat),csref(0:5,nmat),bnref(nmat),freep(nmat)
18506 common/scatu/cprob(0:5,nmat),bn(nmat),bpp,xln15s,ecmsq
18507 common/scatu2/xintl(nmat),radl(nmat),mname
18508 common/scatpp/pptot,ppel,ppsd
18509 common/sppref/pptref,pperef,pref,pptco,ppeco,sdcoe,freeco
18510 common/phase/x,xp,z,zp,dpop
18511 common/nommom/p0
18512 common/cjaw1/zlm
18513 common/cmcs1/zlm1
18514 common/materia/mat
18515 common/sindif/xpsd,zpsd,psd
18516 common/cdpodx/dpodx
18517 real ruth,t
18518 double precision cnorm,cnform
18519 parameter(cnorm=2.607d-4,cnform=0.8561d3)
18520 !c write(6,'('' t,exp'',2e15.8)')t,t*cnform*EMr(mcurr)**2
18521 ruth=cnorm*exp(-t*cnform*emr(mcurr)**2)*(zatom(mcurr)/t)**2
18522 end
18523 !---------------------------------------------------------------
18524 !
18525 block data scdata
18526 !GRD
18527 !GRD CHANGED ON 2/2003 TO INCLUDE CODE FOR C, C2 from JBJ (rwa)
18528 !GRD
18529 implicit none
18530 integer nrmat,nmat,mat,irmat,mcurr
18531 ! parameter(nmat=12,nrmat=5)
18532 parameter(nmat=12,nrmat=7)
18533 double precision xintl,radl,x,xp,z,zp,dpop,p0,zlm,zlm1,xpsd,zpsd, &
18534 &psd,dpodx(nmat),anuc,rho,emr,tlcut,hcut,cs,csref,bnref,freep, &
18535 &cprob,bn,bpp,xln15s,ecmsq,pptot,ppel,ppsd,pptref,pperef,pref, &
18536 &pptco,ppeco,sdcoe,freeco,fnavo,zatom
18537 parameter(fnavo=6.02e23)
18538 real cgen
18539 character * 4 mname(nmat)
18540 integer i
18541 common/mater/anuc(nmat),zatom(nmat),rho(nmat),emr(nmat),irmat
18542 common/coul/tlcut,hcut(nmat),cgen(200,nmat),mcurr
18543 common/scat/cs(0:5,nmat),csref(0:5,nmat),bnref(nmat),freep(nmat)
18544 common/scatu/cprob(0:5,nmat),bn(nmat),bpp,xln15s,ecmsq
18545 common/scatu2/xintl(nmat),radl(nmat),mname
18546 common/scatpp/pptot,ppel,ppsd
18547 common/sppref/pptref,pperef,pref,pptco,ppeco,sdcoe,freeco
18548 common/phase/x,xp,z,zp,dpop
18549 common/nommom/p0
18550 common/cjaw1/zlm
18551 common/cmcs1/zlm1
18552 common/materia/mat
18553 common/sindif/xpsd,zpsd,psd
18554 common/cdpodx/dpodx
18555 ! The last materials are 'vacuum' and 'black', see in sub. SCATIN
18556 ! Number of real materials defined here:
18557 !
18558 !++ CHANGE THE NUMBER OF REAL MATERIALS FROM 5 to 7 (bug in JBJ'S ROUTINE?)
18559 !
18560 ! data irmat/5/
18561 !
18562 data irmat/7/
18563 !
18564 ! Reference data at pRef=450Gev
18565 ! data (mname(i),i=1,nrmat)/ 'Be' , 'Al' , 'Cu' , 'W' , 'Pb' /
18566 data (mname(i),i=1,nrmat)/ 'Be','Al','Cu','W','Pb','C','C2' /
18567 !
18568 ! data mname(nmat-1), mname(nmat)/'vacu','blac'/
18569 data mname(nmat-1), mname(nmat)/'vacu','blac'/
18570 !GRD
18571 !GRD IMPLEMENT CHANGES FROM JBJ, 2/2003 RWA
18572 !GRD
18573 ! data (Anuc(i),i=1,nrmat)/ 9.01, 26.98, 63.55, 183.85, 207.19/
18574 data (anuc(i),i=1,5)/ 9.01d0,26.98d0,63.55d0,183.85d0,207.19d0/
18575 data (anuc(i),i=6,nrmat)/12.01d0,12.01d0/
18576 !
18577 !GRD data (Z(i),i=1,nrmat)/ 4, 13, 29, 74, 82/
18578 data (zatom(i),i=1,5)/ 4d0, 13d0, 29d0, 74d0, 82d0/
18579 data (zatom(i),i=6,nrmat)/ 6d0, 6d0/
18580 !GRD data (Rho(i),i=1,nrmat)/ 1.848, 2.70, 8.96, 19.3, 11.35/
18581 data (rho(i),i=1,5)/ 1.848d0, 2.70d0, 8.96d0, 19.3d0, 11.35d0/
18582 data (rho(i),i=6,nrmat)/ 2.26d0, 4.52d0/
18583 !GRD data (RadL(i),i=1,nrmat)/ 0.353, 0.089, 0.0143, 0.0035, 0.0056/
18584 data (radl(i),i=1,5)/ 0.353d0,0.089d0,0.0143d0,0.0035d0,0.0056d0/
18585 data (radl(i),i=6,nrmat)/ 0.188d0, 0.094d0/
18586 data radl(nmat-1),radl(nmat)/ 1.d12, 1.d12 /
18587 !GRD data (EMR(i),i=1,nrmat)/ 0.22, 0.302, 0.366, 0.0, 0.542/
18588 !MAY06-GRD value for Tungsten (W) not stated
18589 ! data (emr(i),i=1,5)/ 0.22d0, 0.302d0, 0.366d0, 0.0d0, 0.542d0/
18590 data (emr(i),i=1,5)/ 0.22d0, 0.302d0, 0.366d0, 0.520d0, 0.542d0/
18591 !MAY06-GRD end of changes
18592 data (emr(i),i=6,nrmat)/ 0.25d0, 0.25d0/
18593 !GRD data tLcut,(Hcut(i),i=1,nrmat)/0.9982e-3,0.02,0.02,3*0.01/
18594 data tlcut / 0.0009982d0/
18595 data (hcut(i),i=1,5)/0.02d0, 0.02d0, 3*0.01d0/
18596 data (hcut(i),i=6,nrmat)/0.02d0, 0.02d0/
18597 ! data (dpodx(i),i=1,nrmat)/ nrmat*0.d0 /
18598 !GRD data (dpodx(i),i=1,nrmat)/ .55, .81, 2.69, 5.79, 3.4 /
18599 data (dpodx(i),i=1,5)/ .55d0, .81d0, 2.69d0, 5.79d0, 3.4d0 /
18600 data (dpodx(i),i=6,nrmat)/ .75d0, 1.5d0 /
18601 !
18602 ! All cross-sections are in barns,nuclear values from RPP at 20geV
18603 ! Coulomb is integerated above t=tLcut[Gev2] (+-1% out Gauss mcs)
18604 !
18605 ! in Cs and CsRef,1st index: Cross-sections for processes
18606 ! 0:Total, 1:absorption, 2:nuclear elastic, 3:pp or pn elastic
18607 ! 4:Single Diffractive pp or pn, 5:Coulomb for t above mcs
18608 !
18609 !MAY06-GRD: found an error in the values for Rutherford cross-sections,
18610 !as the ones reported here are stated in fm^2 and not in barns, hence
18611 !being 100 times too large...
18612 ! data csref(0,1),csref(1,1),csref(5,1)/0.268d0, 0.199d0 , 0.0035d0/
18613 ! data csref(0,2),csref(1,2),csref(5,2)/0.634d0, 0.421d0 , 0.034d0/
18614 ! data csref(0,3),csref(1,3),csref(5,3)/1.232d0, 0.782d0 , 0.153d0/
18615 ! data csref(0,4),csref(1,4),csref(5,4)/2.767d0, 1.65d0 , 0.768d0/
18616 ! data csref(0,5),csref(1,5),csref(5,5)/2.960d0, 1.77d0 , 0.907d0/
18617 !!GRD
18618 ! data csref(0,6),csref(1,6),csref(5,6)/0.331d0, 0.231d0, 0.0076d0/
18619 ! data csref(0,7),csref(1,7),csref(5,7)/0.331d0, 0.231d0, 0.0076d0/
18620 !
18621 data csref(0,1),csref(1,1),csref(5,1)/0.268d0, 0.199d0, 0.0035d-2/
18622 data csref(0,2),csref(1,2),csref(5,2)/0.634d0, 0.421d0, 0.034d-2/
18623 data csref(0,3),csref(1,3),csref(5,3)/1.232d0, 0.782d0, 0.153d-2/
18624 data csref(0,4),csref(1,4),csref(5,4)/2.767d0, 1.65d0 , 0.768d-2/
18625 data csref(0,5),csref(1,5),csref(5,5)/2.960d0, 1.77d0 , 0.907d-2/
18626 !GRD
18627 data csref(0,6),csref(1,6),csref(5,6)/0.331d0, 0.231d0, 0.0076d-2/
18628 data csref(0,7),csref(1,7),csref(5,7)/0.331d0, 0.231d0, 0.0076d-2/
18629 !MAY06-GRD end of changes
18630 !
18631 ! pp cross-sections and parameters for energy dependence
18632 data pptref,pperef,sdcoe,pref/0.04d0,0.007d0,0.00068d0,450.0d0/
18633 data pptco,ppeco,freeco/0.05788d0,0.04792d0,1.618d0/
18634 ! Nuclear elastic slope from Schiz et al.,PRD 21(3010)1980
18635 !GRD data (bNRef(i),i=1,nrmat)/74.7,120.3,217.8,0.0,455.3/
18636 !MAY06-GRD value for Tungsten (W) not stated
18637 ! data (bnref(i),i=1,5)/74.7d0,120.3d0,217.8d0,0.0d0,455.3d0/
18638 data (bnref(i),i=1,5)/74.7d0,120.3d0,217.8d0,440.3d0,455.3d0/
18639 !MAY06-GRD end of changes
18640 data (bnref(i),i=6,nrmat)/70.d0, 70.d0/
18641 !GRD LAST 2 ONES INTERPOLATED
18642 !
18643 ! Cprob to choose an interaction in iChoix
18644 data (cprob(0,i),i=1,nmat)/nmat*0.0d0/
18645 data (cprob(5,i),i=1,nmat)/nmat*1.0d0/
18646 !
18647 end
18648
18649 !---------------------------------------------------------------
18650 !
18651 subroutine scatin(plab)
18652 implicit none
18653 integer nrmat,nmat,mat,irmat,mcurr
18654 ! parameter(nmat=12,nrmat=5)
18655 parameter(nmat=12,nrmat=7)
18656 double precision xintl,radl,x,xp,z,zp,dpop,p0,zlm,zlm1,xpsd,zpsd, &
18657 &psd,dpodx(nmat),anuc,rho,emr,tlcut,hcut,cs,csref,bnref,freep, &
18658 &cprob,bn,bpp,xln15s,ecmsq,pptot,ppel,ppsd,pptref,pperef,pref, &
18659 &pptco,ppeco,sdcoe,freeco,fnavo,zatom
18660 parameter(fnavo=6.02e23)
18661 real cgen
18662 character * 4 mname(nmat)
18663 common/mater/anuc(nmat),zatom(nmat),rho(nmat),emr(nmat),irmat
18664 common/coul/tlcut,hcut(nmat),cgen(200,nmat),mcurr
18665 common/scat/cs(0:5,nmat),csref(0:5,nmat),bnref(nmat),freep(nmat)
18666 common/scatu/cprob(0:5,nmat),bn(nmat),bpp,xln15s,ecmsq
18667 common/scatu2/xintl(nmat),radl(nmat),mname
18668 common/scatpp/pptot,ppel,ppsd
18669 common/sppref/pptref,pperef,pref,pptco,ppeco,sdcoe,freeco
18670 common/phase/x,xp,z,zp,dpop
18671 common/nommom/p0
18672 common/cjaw1/zlm
18673 common/cmcs1/zlm1
18674 common/materia/mat
18675 common/sindif/xpsd,zpsd,psd
18676 common/cdpodx/dpodx
18677 integer ma,i
18678 double precision plab
18679 real ruth,tlow,thigh
18680 external ruth
18681 ! open(unit=6,file='scatin.out')
18682 !
18683 ecmsq = 2 * 0.93828d0 * plab
18684 xln15s=log(0.15*ecmsq)
18685 ! pp(pn) data
18686 pptot = pptref *(plab / pref)** pptco
18687 ppel = pperef *(plab / pref)** ppeco
18688 ppsd = sdcoe * log(0.15d0 * ecmsq)
18689 bpp = 8.5d0 + 1.086d0 * log(sqrt(ecmsq))
18690 ! unmeasured tungsten data,computed with lead data and power laws
18691 bnref(4) = bnref(5)*(anuc(4) / anuc(5))**(2d0/3d0)
18692 emr(4) = emr(5) * (anuc(4)/anuc(5))**(1d0/3d0)
18693 10 format(/' ppRef TOT El ',4f12.6//)
18694 ! write(6,10)ppTRef,ppEref
18695 11 format(/' pp TOT El Sd b',4f12.6//)
18696 ! write(6,11)ppTot,ppEl,ppSD,bpp
18697 !
18698 ! Compute cross-sections (CS) and probabilities + Interaction length
18699 ! Last two material treated below statement number 100
18700 !
18701 tlow=tlcut
18702 do 100 ma=1,irmat
18703 mcurr=ma
18704 ! prepare for Rutherford differential distribution
18705 thigh=hcut(ma)
18706 call funlxp ( ruth , cgen(1,ma) ,tlow, thigh )
18707 !
18708 ! freep: number of nucleons involved in single scattering
18709 freep(ma) = freeco * anuc(ma)**(1d0/3d0)
18710 ! compute pp and pn el+single diff contributions to cross-section
18711 ! (both added : quasi-elastic or qel later)
18712 cs(3,ma) = freep(ma) * ppel
18713 cs(4,ma) = freep(ma) * ppsd
18714 !
18715 ! correct TOT-CSec for energy dependence of qel
18716 ! TOT CS is here without a Coulomb contribution
18717 cs(0,ma) = csref(0,ma) + freep(ma) * (pptot - pptref)
18718 bn(ma) = bnref(ma) * cs(0,ma) / csref(0,ma)
18719 ! also correct inel-CS
18720 cs(1,ma) = csref(1,ma) * cs(0,ma) / csref(0,ma)
18721 !
18722 ! Nuclear Elastic is TOT-inel-qel ( see definition in RPP)
18723 cs(2,ma) = cs(0,ma) - cs(1,ma) - cs(3,ma) - cs(4,ma)
18724 cs(5,ma) = csref(5,ma)
18725 ! Now add Coulomb
18726 cs(0,ma) = cs(0,ma) + cs(5,ma)
18727 ! Interaction length in meter
18728 xintl(ma) = 0.01d0*anuc(ma)/(fnavo * rho(ma)*cs(0,ma)*1d-24)
18729 !
18730 20 format(/1x,a4,' Int.Len. ',f10.6,' CsTot',2f12.4/)
18731 ! write(6,20)mname(ma),xIntL(ma),Cs(0,ma),CsRef(0,ma)
18732 21 format(' bN freep',2 f12.6,' emR ',f7.4/)
18733 ! write(6,21)bN(ma),freep(ma),emR(ma)
18734 ! Filling CProb with cumulated normalised Cross-sections
18735 do 50 i=1,4
18736 cprob(i,ma)=cprob(i-1,ma)+cs(i,ma)/cs(0,ma)
18737 ! write(6,22)i,Cprob(i,ma),Cs(i,ma),CsRef(i,ma)
18738 50 continue
18739 ! write(6,22)5,Cprob(5,ma),Cs(5,ma),CsRef(5,ma)
18740 22 format(i4,' prob CS CsRref',3(f12.5,2x))
18741 100 continue
18742 !
18743 ! Last two materials for 'vaccum' (nmat-1) and 'full black' (nmat)
18744 !
18745 cprob(1,nmat-1)=1d0
18746 cprob(1,nmat)=1d0
18747 xintl(nmat-1)=1d12
18748 xintl(nmat)=0.0d0
18749 120 format(/1x,a4,' Int.Len. ',e10.3/)
18750 ! write(6,120)mname(nmat-1),xIntL(nmat-1)
18751 ! write(6,120)mname(nmat),xIntL(nmat)
18752 return
18753 end
18754
18755 !-----------------------------------------------------------------------
18756 !
18757 subroutine jaw(s,nabs)
18758 !
18759 !++ Input: ZLM is interaction length
18760 !++ MAT is choice of material
18761 !
18762 !++ Output: nabs = 1 Particle is absorped
18763 !++ nabs = 4 Single-diffractive scattering
18764 !++ dpop Adjusted for momentum loss (dE/dx)
18765 !++ s Exit longitudinal position
18766 !
18767 !++ Physics: If monte carlo interaction length greater than input
18768 !++ interaction length, then use input interaction length
18769 !++ Is that justified???
18770 !
18771 ! nabs=1....absorption
18772 !
18773 implicit none
18774 !
18775 integer nrmat,nmat,mat,irmat,mcurr
18776 ! parameter(nmat=12,nrmat=5)
18777 parameter(nmat=12,nrmat=7)
18778 double precision xintl,radl,x,xp,z,zp,dpop,p0,zlm,zlm1,xpsd,zpsd, &
18779 &psd,dpodx(nmat),anuc,rho,emr,tlcut,hcut,cs,csref,bnref,freep, &
18780 &cprob,bn,bpp,xln15s,ecmsq,pptot,ppel,ppsd,pptref,pperef,pref, &
18781 &pptco,ppeco,sdcoe,freeco,fnavo,zatom
18782 parameter(fnavo=6.02e23)
18783 real cgen
18784 character * 4 mname(nmat)
18785 common/mater/anuc(nmat),zatom(nmat),rho(nmat),emr(nmat),irmat
18786 common/coul/tlcut,hcut(nmat),cgen(200,nmat),mcurr
18787 common/scat/cs(0:5,nmat),csref(0:5,nmat),bnref(nmat),freep(nmat)
18788 common/scatu/cprob(0:5,nmat),bn(nmat),bpp,xln15s,ecmsq
18789 common/scatu2/xintl(nmat),radl(nmat),mname
18790 common/scatpp/pptot,ppel,ppsd
18791 common/sppref/pptref,pperef,pref,pptco,ppeco,sdcoe,freeco
18792 common/phase/x,xp,z,zp,dpop
18793 common/nommom/p0
18794 common/cjaw1/zlm
18795 common/cmcs1/zlm1
18796 common/materia/mat
18797 common/sindif/xpsd,zpsd,psd
18798 common/cdpodx/dpodx
18799 integer nabs,inter,ichoix
18800 double precision p,rlen,s,t,gettran,dxp,dzp,p1
18801 real rndm4
18802 !...cne=1/(sqrt(b))
18803 !...dpodx=dE/(dx*c)
18804 !
18805 !++ Note that the input parameter is dpop. Here the momentum p is
18806 !++ constructed out of this input.
18807 !
18808 ! p=p0/(1.d0-dpop)
18809 p=p0*(1.d0+dpop)
18810 nabs=0
18811 if(mat.eq.nmat) then
18812 !
18813 !++ Collimator treated as black absorber
18814 !
18815 nabs=1
18816 s=0d0
18817 return
18818 else if(mat.eq.nmat-1) then
18819 !
18820 !++ Collimator treated as drift
18821 !
18822 s=zlm
18823 x=x+s*xp
18824 z=z+s*zp
18825 return
18826 end if
18827 !
18828 !++ Initialize the interaction length to input interaction length
18829 !
18830 rlen=zlm
18831 !
18832 !++ Do a step for a point-like interaction. This is a loop with
18833 !++ label 10!!!
18834 !
18835 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
18836 !++ Get monte-carlo interaction length.
18837 !
18838 10 zlm1=-xintl(mat)*log(dble(rndm4()))
18839 !
18840 if(zlm1.gt.rlen) then
18841 !
18842 !++ If the monte-carlo interaction length is shorter than the
18843 !++ remaining collimator length, then put it to the remaining
18844 !++ length, do multiple coulomb scattering and return.
18845 !++ LAST STEP IN ITERATION LOOP
18846 !
18847 zlm1=rlen
18848 call mcs(s)
18849 s=zlm-rlen+s
18850 p=p-dpodx(mat)*s
18851 ! dpop=1.d0-p0/p
18852 dpop=(p-p0)/p0
18853 return
18854 end if
18855 !
18856 !++ Otherwise do multi-coulomb scattering.
18857 !++ REGULAR STEP IN ITERATION LOOP
18858 !
18859 call mcs(s)
18860 !
18861 !++ Check if particle is outside of collimator (X.LT.0) after
18862 !++ MCS. If yes, calculate output longitudinal position (s),
18863 !++ reduce momentum (output as dpop) and return.
18864 !++ PARTICLE LEFT COLLIMATOR BEFORE ITS END.
18865 !
18866 if(x.le.0d0) then
18867 s=zlm-rlen+s
18868 p=p-dpodx(mat)*s
18869 dpop=(p-p0)/p0
18870 return
18871 end if
18872 !
18873 !++ Check whether particle is absorbed. If yes, calculate output
18874 !++ longitudinal position (s), reduce momentum (output as dpop)
18875 !++ and return.
18876 !++ PARTICLE WAS ABSORPED INSIDE COLLIMATOR DURING MCS.
18877 !
18878 inter=ichoix(mat)
18879 if(inter.eq.1) then
18880 nabs=1
18881 s=zlm-rlen+zlm1
18882 p=p-dpodx(mat)*s
18883 dpop=(p-p0)/p0
18884 return
18885 end if
18886 !
18887 !++ Now treat the other types of interaction, as determined by ICHOIX:
18888 !
18889 !++ Nuclear-Elastic: inter = 2
18890 !++ pp Elastic: inter = 3
18891 !++ Single-Diffractive: inter = 4 (changes momentum p)
18892 !++ Coulomb: inter = 5
18893 !
18894 !++ As the single-diffractive interaction changes the momentum, save
18895 !++ input momentum in p1.
18896 !
18897 p1 = p
18898 !
18899 !++ Gettran returns some monte carlo number, that, as I believe, gives
18900 !++ the rms transverse momentum transfer.
18901 !
18902 t = gettran(inter,mat,p)
18903 !
18904 !++ Tetat calculates from the rms transverse momentum transfer in
18905 !++ monte-carlo fashion the angle changes for x and z planes. The
18906 !++ angle change is proportional to SQRT(t) and 1/p, as expected.
18907 !
18908 call tetat(t,p,dxp,dzp)
18909 !
18910 !++ Apply angle changes
18911 !
18912 xp=xp+dxp
18913 zp=zp+dzp
18914 !
18915 !++ Treat single-diffractive scattering.
18916 !
18917 if(inter.eq.4) then
18918 nabs=4
18919 !
18920 !++ added update for s
18921 !
18922 s=zlm-rlen+zlm1
18923 xpsd=dxp
18924 zpsd=dzp
18925 psd=p1
18926 !
18927 !++ Add this code to get the momentum transfer also in the calling
18928 !++ routine...
18929 !
18930 dpop=(p-p0)/p0
18931 !
18932 end if
18933 !
18934 !++ Calculate the remaining interaction length and close the iteration
18935 !++ loop.
18936 !
18937 rlen=rlen-zlm1
18938 goto 10
18939 !
18940 end
18941 !------------------------------------------------------------------------
18942 !-----------------------------------------------------------------------
18943 !
18944 subroutine jaw0(s,nabs)
18945 !
18946 !++ Input: ZLM is interaction length
18947 !++ MAT is choice of material
18948 !
18949 !++ Output: nabs = 1 Particle is absorped
18950 !++ nabs = 4 Single-diffractive scattering
18951 !++ dpop Adjusted for momentum loss (dE/dx)
18952 !++ s Exit longitudinal position
18953 !
18954 !++ Physics: If monte carlo interaction length greater than input
18955 !++ interaction length, then use input interaction length
18956 !++ Is that justified???
18957 !
18958 ! nabs=1....absorption
18959 !
18960 implicit none
18961 !
18962 integer nrmat,nmat,mat,irmat,mcurr
18963 ! parameter(nmat=12,nrmat=5)
18964 parameter(nmat=12,nrmat=7)
18965 double precision xintl,radl,x,xp,z,zp,dpop,p0,zlm,zlm1,xpsd,zpsd, &
18966 &psd,dpodx(nmat),anuc,rho,emr,tlcut,hcut,cs,csref,bnref,freep, &
18967 &cprob,bn,bpp,xln15s,ecmsq,pptot,ppel,ppsd,pptref,pperef,pref, &
18968 &pptco,ppeco,sdcoe,freeco,fnavo,zatom
18969 parameter(fnavo=6.02e23)
18970 real cgen
18971 character * 4 mname(nmat)
18972 common/mater/anuc(nmat),zatom(nmat),rho(nmat),emr(nmat),irmat
18973 common/coul/tlcut,hcut(nmat),cgen(200,nmat),mcurr
18974 common/scat/cs(0:5,nmat),csref(0:5,nmat),bnref(nmat),freep(nmat)
18975 common/scatu/cprob(0:5,nmat),bn(nmat),bpp,xln15s,ecmsq
18976 common/scatu2/xintl(nmat),radl(nmat),mname
18977 common/scatpp/pptot,ppel,ppsd
18978 common/sppref/pptref,pperef,pref,pptco,ppeco,sdcoe,freeco
18979 common/phase/x,xp,z,zp,dpop
18980 common/nommom/p0
18981 common/cjaw1/zlm
18982 common/cmcs1/zlm1
18983 common/materia/mat
18984 common/sindif/xpsd,zpsd,psd
18985 common/cdpodx/dpodx
18986 integer nabs,inter,ichoix
18987 double precision p,rlen,s,t,gettran,dxp,dzp,p1
18988 real rndm4
18989 !...cne=1/(sqrt(b))
18990 !...dpodx=dE/(dx*c)
18991 p=p0/(1.d0-dpop)
18992 nabs=0
18993 if(mat.eq.nmat) then
18994 !
18995 !++ Collimator treated as black absorber
18996 !
18997 nabs=1
18998 s=0d0
18999 return
19000 else if(mat.eq.nmat-1) then
19001 !
19002 !++ Collimator treated as drift
19003 !
19004 s=zlm
19005 x=x+s*xp
19006 z=z+s*zp
19007 return
19008 end if
19009 !
19010 !++ Initialize the interaction length to input interaction length
19011 !
19012 rlen=zlm
19013 !
19014 !++ Do a step for a point-like interaction. This is a loop with
19015 !++ label 10!!!
19016 !
19017 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
19018 !++ Get monte-carlo interaction length.
19019 !
19020 10 zlm1=-xintl(mat)*log(dble(rndm4()))
19021 !
19022 if(zlm1.gt.rlen) then
19023 !
19024 !++ If the monte-carlo interaction length is shorter than the
19025 !++ remaining collimator length, then put it to the remaining
19026 !++ length, do multiple coulomb scattering and return.
19027 !++ LAST STEP IN ITERATION LOOP
19028 !
19029 zlm1=rlen
19030 call mcs(s)
19031 s=zlm-rlen+s
19032 p=p-dpodx(mat)*s
19033 dpop=1.d0-p0/p
19034 return
19035 end if
19036 !
19037 !++ Otherwise do multi-coulomb scattering.
19038 !++ REGULAR STEP IN ITERATION LOOP
19039 !
19040 call mcs(s)
19041 !
19042 !++ Check if particle is outside of collimator (X.LT.0) after
19043 !++ MCS. If yes, calculate output longitudinal position (s),
19044 !++ reduce momentum (output as dpop) and return.
19045 !++ PARTICLE LEFT COLLIMATOR BEFORE ITS END.
19046 !
19047 if(x.le.0.d0) then
19048 s=zlm-rlen+s
19049 p=p-dpodx(mat)*s
19050 dpop=1.d0-p0/p
19051 return
19052 end if
19053 !
19054 !++ Check whether particle is absorbed. If yes, calculate output
19055 !++ longitudinal position (s), reduce momentum (output as dpop)
19056 !++ and return.
19057 !++ PARTICLE WAS ABSORPED INSIDE COLLIMATOR DURING MCS.
19058 !
19059 inter=ichoix(mat)
19060 if(inter.eq.1) then
19061 nabs=1
19062 s=zlm-rlen+zlm1
19063 p=p-dpodx(mat)*s
19064 dpop=1.d0-p0/p
19065 return
19066 end if
19067 !
19068 !++ Now treat the other types of interaction, as determined by ICHOIX:
19069 !
19070 !++ Nuclear-Elastic: inter = 2
19071 !++ pp Elastic: inter = 3
19072 !++ Single-Diffractive: inter = 4 (changes momentum p)
19073 !++ Coulomb: inter = 5
19074 !
19075 !++ As the single-diffractive interaction changes the momentum, save
19076 !++ input momentum in p1.
19077 !
19078 p1 = p
19079 !
19080 !++ Gettran returns some monte carlo number, that, as I believe, gives
19081 !++ the rms transverse momentum transfer.
19082 !
19083 t = gettran(inter,mat,p)
19084 !
19085 !++ Tetat calculates from the rms transverse momentum transfer in
19086 !++ monte-carlo fashion the angle changes for x and z planes. The
19087 !++ angle change is proportional to SQRT(t) and 1/p, as expected.
19088 !
19089 call tetat(t,p,dxp,dzp)
19090 !
19091 !++ Apply angle changes
19092 !
19093 xp=xp+dxp
19094 zp=zp+dzp
19095 !
19096 !++ Treat single-diffractive scattering.
19097 !
19098 if(inter.eq.4) then
19099 nabs=4
19100 xpsd=dxp
19101 zpsd=dzp
19102 psd=p1
19103 end if
19104 !
19105 !++ Calculate the remaining interaction length and close the iteration
19106 !++ loop.
19107 !
19108 rlen=rlen-zlm1
19109 goto 10
19110 !
19111 end
19112 !------------------------------------------------------------------------
19113
19114 subroutine mcs(s)
19115 !
19116 !++ Input: zlm1 Monte-carlo interaction length
19117 !
19118 !++ Output: s Longitudinal position
19119 !++ p0 Reference momentum
19120 !++ dpop Relative momentum offset
19121 !
19122 ! collimator: x>0 and y<zlm1
19123 !
19124 implicit none
19125 ! save h,dh,bn
19126 integer nrmat,nmat,mat,irmat,mcurr
19127 ! parameter(nmat=12,nrmat=5)
19128 parameter(nmat=12,nrmat=7)
19129 double precision xintl,radl,x,xp,z,zp,dpop,p0,zlm,zlm1,xpsd,zpsd, &
19130 &psd,dpodx(nmat),anuc,rho,emr,tlcut,hcut,cs,csref,bnref,freep, &
19131 &cprob,bn,bpp,xln15s,ecmsq,pptot,ppel,ppsd,pptref,pperef,pref, &
19132 &pptco,ppeco,sdcoe,freeco,fnavo,zatom
19133 parameter(fnavo=6.02e23)
19134 real cgen
19135 character * 4 mname(nmat)
19136 common/mater/anuc(nmat),zatom(nmat),rho(nmat),emr(nmat),irmat
19137 common/coul/tlcut,hcut(nmat),cgen(200,nmat),mcurr
19138 common/scat/cs(0:5,nmat),csref(0:5,nmat),bnref(nmat),freep(nmat)
19139 common/scatu/cprob(0:5,nmat),bn(nmat),bpp,xln15s,ecmsq
19140 common/scatu2/xintl(nmat),radl(nmat),mname
19141 common/scatpp/pptot,ppel,ppsd
19142 common/sppref/pptref,pperef,pref,pptco,ppeco,sdcoe,freeco
19143 common/phase/x,xp,z,zp,dpop
19144 common/nommom/p0
19145 common/cjaw1/zlm
19146 common/cmcs1/zlm1
19147 common/materia/mat
19148 common/sindif/xpsd,zpsd,psd
19149 common/cdpodx/dpodx
19150 double precision h,dh,theta,rlen0,rlen,ae,be,bn0,s
19151 ! bn=sqrt(3)/(number of sigmas for s-determination(=4))
19152 data h/.001d0/dh/.0001d0/bn0/.4330127019d0/
19153 !
19154 !++
19155 !
19156 theta=13.6d-3*(1.d0-dpop)/p0
19157 x=x/theta/radl(mat)
19158 xp=xp/theta
19159 z=z/theta/radl(mat)
19160 zp=zp/theta
19161 rlen0=zlm1/radl(mat)
19162 rlen=rlen0
19163 10 ae=bn0*x
19164 be=bn0*xp
19165 call soln3(ae,be,dh,rlen,s)
19166 if(s.lt.h) s=h
19167 call scamcs(x,xp,s)
19168 if(x.le.0.d0) then
19169 s=rlen0-rlen+s
19170 goto 20
19171 end if
19172 if(s+dh.ge.rlen) then
19173 s=rlen0
19174 goto 20
19175 end if
19176 rlen=rlen-s
19177 goto 10
19178 20 call scamcs(z,zp,s)
19179 s=s*radl(mat)
19180 x=x*theta*radl(mat)
19181 xp=xp*theta
19182 z=z*theta*radl(mat)
19183 zp=zp*theta
19184 end
19185
19186 subroutine scamcs(xx,xxp,s)
19187 implicit none
19188 double precision v1,v2,r2,a,z1,z2,ss,s,xx,xxp,x0,xp0
19189 real rndm4
19190 x0=xx
19191 xp0=xxp
19192 5 v1=2d0*rndm4()-1d0
19193 v2=2d0*rndm4()-1d0
19194 r2=v1*v1+v2*v2
19195 if(r2.ge.1.d0) goto 5
19196 a=dsqrt(-2.d0*log(r2)/r2)
19197 z1=v1*a
19198 z2=v2*a
19199 ss=dsqrt(s)
19200 xx=x0+s*(xp0+.5d0*ss*(z2+z1*.577350269d0))
19201 ! x=x0+s*(xp0+.5d0*ss*(z2+z1/dsqrt(3.d0)))
19202 xxp=xp0+ss*z2
19203 end
19204
19205 !-------------------------------------------------------------
19206
19207 subroutine soln3(a,b,dh,smax,s)
19208 implicit none
19209 double precision b,a,s,smax,c,dh
19210 if(b.eq.0.d0) then
19211 s=a**0.6666666666666667d0
19212 ! s=a**(2.d0/3.d0)
19213 if(s.gt.smax) s=smax
19214 return
19215 end if
19216 if(a.eq.0.d0) then
19217 if(b.gt.0.d0) then
19218 s=b**2
19219 else
19220 s=0.d0
19221 end if
19222 if(s.gt.smax) s=smax
19223 return
19224 end if
19225 if(b.gt.0.d0) then
19226 if(smax**3.le.(a+b*smax)**2) then
19227 s=smax
19228 return
19229 else
19230 s=smax*.5d0
19231 call iterat(a,b,dh,s)
19232 end if
19233 else
19234 c=-a/b
19235 if(smax.lt.c) then
19236 if(smax**3.le.(a+b*smax)**2) then
19237 s=smax
19238 return
19239 else
19240 s=smax*.5d0
19241 call iterat(a,b,dh,s)
19242 end if
19243 else
19244 s=c*.5d0
19245 call iterat(a,b,dh,s)
19246 end if
19247 end if
19248 end
19249
19250
19251 subroutine iterat(a,b,dh,s)
19252 implicit none
19253 double precision ds,s,a,b,dh
19254
19255 ds=s
19256 10 ds=ds*.5d0
19257 if(s**3.lt.(a+b*s)**2) then
19258 s=s+ds
19259 else
19260 s=s-ds
19261 end if
19262 if(ds.lt.dh) then
19263 return
19264 else
19265 goto 10
19266 end if
19267 end
19268 !
19269 !cccccccccccccccccccccccccccccccccc
19270 !
19271 function rndm4()
19272 implicit none
19273 integer len, in
19274 real rndm4, a
19275 save
19276 parameter ( len = 30000 )
19277 dimension a(len)
19278 data in/1/
19279 !
19280 if ( in.eq.1 ) then
19281 call ranlux(a,len)
19282 rndm4=a(1)
19283 in=2
19284 ! write(6,'('' LEN: '',i5)')LEN
19285 else
19286 rndm4=a(in)
19287 in=in+1
19288 if(in.eq.len+1)in=1
19289 endif
19290 return
19291 end
19292 !
19293 !
19294 !ccccccccccccccccccccccccccccccccccccccc
19295 !-TW-01/2007
19296 ! function rndm5(irnd) , irnd = 1 will reset
19297 ! inn counter => enables reproducible set of
19298 ! random unmbers
19299 !cccccccccccccccccccccccccccccccccc
19300 !
19301 function rndm5(irnd)
19302 implicit none
19303 integer len, inn, irnd
19304 real rndm5, a
19305 save
19306 parameter ( len = 30000 )
19307 dimension a(len)
19308 data inn/1/
19309 !
19310 ! reset inn to 1 enable reproducible random numbers
19311 if ( irnd .eq. 1) inn = 1
19312 if ( inn.eq.1 ) then
19313 call ranlux(a,len)
19314 rndm5=a(1)
19315 inn=2
19316 else
19317 rndm5=a(inn)
19318 inn=inn+1
19319 if(inn.eq.len+1)inn=1
19320 endif
19321 return
19322 end
19323 !
19324 !ccccccccccccccccccccccccccccccccccccccc
19325 !
19326 !
19327 double precision function myran_gauss(cut)
19328 !*********************************************************************
19329 !
19330 ! myran_gauss - will generate a normal distribution from a uniform
19331 ! distribution between [0,1].
19332 ! See "Communications of the ACM", V. 15 (1972), p. 873.
19333 !
19334 ! cut - double precision - cut for distribution in units of sigma
19335 ! the cut must be greater than 0.5
19336 !
19337 ! changed rndm4 to rndm5(irnd) and defined flag as true
19338 !
19339 !*********************************************************************
19340 implicit none
19341
19342 logical flag
19343 real rndm5
19344 double precision x, u1, u2, twopi, r,cut
19345 save
19346
19347 flag = .true.
19348
19349 twopi=8d0*atan(1d0)
19350 1 if (flag) then
19351 r = dble(rndm5(0))
19352 r = max(r, 0.5d0**32)
19353 r = min(r, 1d0-0.5d0**32)
19354 u1 = sqrt(-2d0*log( r ))
19355 u2 = dble(rndm5(0))
19356 x = u1 * cos(twopi*u2)
19357 else
19358 x = u1 * sin(twopi*u2)
19359 endif
19360
19361 flag = .not. flag
19362
19363 ! cut the distribution if cut > 0.5
19364 if (cut .gt. 0.5d0 .and. abs(x) .gt. cut) goto 1
19365
19366 myran_gauss = x
19367 return
19368 end
19369 !
19370 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
19371
19372 !
19373 ! $Id: ranlux.F,v 1.2 1997/09/22 13:45:47 mclareni Exp $
19374 !
19375 ! $Log: ranlux.F,v $
19376 ! Revision 1.2 1997/09/22 13:45:47 mclareni
19377 ! Correct error in initializing RANLUX by using RLUXIN with the output of
19378 ! RLUXUT from a previous run.
19379 !
19380 ! Revision 1.1.1.1 1996/04/01 15:02:55 mclareni
19381 ! Mathlib gen
19382 !
19383 !
19384 subroutine ranlux(rvec,lenv)
19385 ! Subtract-and-borrow random number generator proposed by
19386 ! Marsaglia and Zaman, implemented by F. James with the name
19387 ! RCARRY in 1991, and later improved by Martin Luescher
19388 ! in 1993 to produce "Luxury Pseudorandom Numbers".
19389 ! Fortran 77 coded by F. James, 1993
19390 !
19391 ! LUXURY LEVELS.
19392 ! ------ ------ The available luxury levels are:
19393 !
19394 ! level 0 (p=24): equivalent to the original RCARRY of Marsaglia
19395 ! and Zaman, very long period, but fails many tests.
19396 ! level 1 (p=48): considerable improvement in quality over level 0,
19397 ! now passes the gap test, but still fails spectral test.
19398 ! level 2 (p=97): passes all known tests, but theoretically still
19399 ! defective.
19400 ! level 3 (p=223): DEFAULT VALUE. Any theoretically possible
19401 ! correlations have very small chance of being observed.
19402 ! level 4 (p=389): highest possible luxury, all 24 bits chaotic.
19403 !
19404 !!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
19405 !!! Calling sequences for RANLUX: ++
19406 !!! CALL RANLUX (RVEC, LEN) returns a vector RVEC of LEN ++
19407 !!! 32-bit random floating point numbers between ++
19408 !!! zero (not included) and one (also not incl.). ++
19409 !!! CALL RLUXGO(LUX,INT,K1,K2) initializes the generator from ++
19410 !!! one 32-bit integer INT and sets Luxury Level LUX ++
19411 !!! which is integer between zero and MAXLEV, or if ++
19412 !!! LUX .GT. 24, it sets p=LUX directly. K1 and K2 ++
19413 !!! should be set to zero unless restarting at a break++
19414 !!! point given by output of RLUXAT (see RLUXAT). ++
19415 !!! CALL RLUXAT(LUX,INT,K1,K2) gets the values of four integers++
19416 !!! which can be used to restart the RANLUX generator ++
19417 !!! at the current point by calling RLUXGO. K1 and K2++
19418 !!! specify how many numbers were generated since the ++
19419 !!! initialization with LUX and INT. The restarting ++
19420 !!! skips over K1+K2*E9 numbers, so it can be long.++
19421 !!! A more efficient but less convenient way of restarting is by: ++
19422 !!! CALL RLUXIN(ISVEC) restarts the generator from vector ++
19423 !!! ISVEC of 25 32-bit integers (see RLUXUT) ++
19424 !!! CALL RLUXUT(ISVEC) outputs the current values of the 25 ++
19425 !!! 32-bit integer seeds, to be used for restarting ++
19426 !!! ISVEC must be dimensioned 25 in the calling program ++
19427 !!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
19428 implicit none
19429 integer lenv,isdext,iseeds,maxlev,ndskip,itwo24,next,j24,i24, &
19430 &inseed,mkount,kount,in24,nskip,lxdflt,jsdflt,jseed,lp,i,k,icons, &
19431 &inner,izip,izip2,ivec,isk,igiga,isd,k2,k1,inout,lout,ins,lux,ilx, &
19432 &iouter
19433 real rvec,seeds,twop12,twom12,twom24,carry,uni
19434 dimension rvec(lenv)
19435 dimension seeds(24), iseeds(24), isdext(25)
19436 parameter (maxlev=4, lxdflt=3)
19437 dimension ndskip(0:maxlev)
19438 dimension next(24)
19439 parameter (twop12=4096., igiga=1000000000,jsdflt=314159265)
19440 parameter (itwo24=2**24, icons=2147483563)
19441 save notyet, i24, j24, carry, seeds, twom24, twom12, luxlev
19442 save nskip, ndskip, in24, next, kount, mkount, inseed
19443 integer luxlev
19444 logical notyet
19445 data notyet, luxlev, in24, kount, mkount /.true., lxdflt, 0,0,0/
19446 data i24,j24,carry/24,10,0./
19447 ! default
19448 ! Luxury Level 0 1 2 *3* 4
19449 data ndskip/0, 24, 73, 199, 365 /
19450 !Corresponds to p=24 48 97 223 389
19451 ! time factor 1 2 3 6 10 on slow workstation
19452 ! 1 1.5 2 3 5 on fast mainframe
19453 !
19454 ! NOTYET is .TRUE. if no initialization has been performed yet.
19455 ! Default Initialization by Multiplicative Congruential
19456 if (notyet) then
19457 notyet = .false.
19458 jseed = jsdflt
19459 inseed = jseed
19460 write(*,'(A,I12)') ' RANLUX DEFAULT INITIALIZATION: ',jseed
19461 luxlev = lxdflt
19462 nskip = ndskip(luxlev)
19463 lp = nskip + 24
19464 in24 = 0
19465 kount = 0
19466 mkount = 0
19467 ! WRITE(6,'(A,I2,A,I4)') ' RANLUX DEFAULT LUXURY LEVEL = ',
19468 ! & LUXLEV,' p =',LP
19469 twom24 = 1.
19470 do 25 i= 1, 24
19471 twom24 = twom24 * 0.5
19472 k = jseed/53668
19473 jseed = 40014*(jseed-k*53668) -k*12211
19474 if (jseed .lt. 0) jseed = jseed+icons
19475 iseeds(i) = mod(jseed,itwo24)
19476 25 continue
19477 twom12 = twom24 * 4096.
19478 do 50 i= 1,24
19479 seeds(i) = real(iseeds(i))*twom24
19480 next(i) = i-1
19481 50 continue
19482 next(1) = 24
19483 i24 = 24
19484 j24 = 10
19485 carry = 0.
19486 if (seeds(24) .eq. 0.) carry = twom24
19487 endif
19488 !
19489 ! The Generator proper: "Subtract-with-borrow",
19490 ! as proposed by Marsaglia and Zaman,
19491 ! Florida State University, March, 1989
19492 !
19493 do 100 ivec= 1, lenv
19494 uni = seeds(j24) - seeds(i24) - carry
19495 if (uni .lt. 0.) then
19496 uni = uni + 1.
19497 carry = twom24
19498 else
19499 carry = 0.
19500 endif
19501 seeds(i24) = uni
19502 i24 = next(i24)
19503 j24 = next(j24)
19504 rvec(ivec) = uni
19505 ! small numbers (with less than 12 "significant" bits) are "padded".
19506 if (uni .lt. twom12) then
19507 rvec(ivec) = rvec(ivec) + twom24*seeds(j24)
19508 ! and zero is forbidden in case someone takes a logarithm
19509 if (rvec(ivec) .eq. 0.) rvec(ivec) = twom24*twom24
19510 endif
19511 ! Skipping to luxury. As proposed by Martin Luscher.
19512 in24 = in24 + 1
19513 if (in24 .eq. 24) then
19514 in24 = 0
19515 kount = kount + nskip
19516 do 90 isk= 1, nskip
19517 uni = seeds(j24) - seeds(i24) - carry
19518 if (uni .lt. 0.) then
19519 uni = uni + 1.
19520 carry = twom24
19521 else
19522 carry = 0.
19523 endif
19524 seeds(i24) = uni
19525 i24 = next(i24)
19526 j24 = next(j24)
19527 90 continue
19528 endif
19529 100 continue
19530 kount = kount + lenv
19531 if (kount .ge. igiga) then
19532 mkount = mkount + 1
19533 kount = kount - igiga
19534 endif
19535 return
19536 !
19537 ! Entry to input and float integer seeds from previous run
19538 entry rluxin(isdext)
19539 notyet = .false.
19540 twom24 = 1.
19541 do 195 i= 1, 24
19542 next(i) = i-1
19543 195 twom24 = twom24 * 0.5
19544 next(1) = 24
19545 twom12 = twom24 * 4096.
19546 write(*,*) ' FULL INITIALIZATION OF RANLUX WITH 25 INTEGERS:'
19547 write(*,'(5X,5I12)') isdext
19548 do 200 i= 1, 24
19549 seeds(i) = real(isdext(i))*twom24
19550 200 continue
19551 carry = 0.
19552 if (isdext(25) .lt. 0) carry = twom24
19553 isd = iabs(isdext(25))
19554 i24 = mod(isd,100)
19555 isd = isd/100
19556 j24 = mod(isd,100)
19557 isd = isd/100
19558 in24 = mod(isd,100)
19559 isd = isd/100
19560 luxlev = isd
19561 if (luxlev .le. maxlev) then
19562 nskip = ndskip(luxlev)
19563 write(*,'(A,I2)') ' RANLUX LUXURY LEVEL SET BY RLUXIN TO: ', &
19564 &luxlev
19565 else if (luxlev .ge. 24) then
19566 nskip = luxlev - 24
19567 write(*,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXIN TO:',luxlev
19568 else
19569 nskip = ndskip(maxlev)
19570 write(*,'(A,I5)') ' RANLUX ILLEGAL LUXURY RLUXIN: ',luxlev
19571 luxlev = maxlev
19572 endif
19573 inseed = -1
19574 return
19575 !
19576 ! Entry to ouput seeds as integers
19577 entry rluxut(isdext)
19578 do 300 i= 1, 24
19579 isdext(i) = int(seeds(i)*twop12*twop12)
19580 300 continue
19581 isdext(25) = i24 + 100*j24 + 10000*in24 + 1000000*luxlev
19582 if (carry .gt. 0.) isdext(25) = -isdext(25)
19583 return
19584 !
19585 ! Entry to output the "convenient" restart point
19586 entry rluxat(lout,inout,k1,k2)
19587 lout = luxlev
19588 inout = inseed
19589 k1 = kount
19590 k2 = mkount
19591 return
19592 !
19593 ! Entry to initialize from one or three integers
19594 entry rluxgo(lux,ins,k1,k2)
19595 if (lux .lt. 0) then
19596 luxlev = lxdflt
19597 else if (lux .le. maxlev) then
19598 luxlev = lux
19599 else if (lux .lt. 24 .or. lux .gt. 2000) then
19600 luxlev = maxlev
19601 write(*,'(A,I7)') ' RANLUX ILLEGAL LUXURY RLUXGO: ',lux
19602 else
19603 luxlev = lux
19604 do 310 ilx= 0, maxlev
19605 if (lux .eq. ndskip(ilx)+24) luxlev = ilx
19606 310 continue
19607 endif
19608 if (luxlev .le. maxlev) then
19609 nskip = ndskip(luxlev)
19610 write(*,'(A,I2,A,I4)') ' RANLUX LUXURY LEVEL SET BY RLUXGO :', &
19611 &luxlev,' P=', nskip+24
19612 else
19613 nskip = luxlev - 24
19614 write(*,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXGO TO:',luxlev
19615 endif
19616 in24 = 0
19617 if (ins .lt. 0) write(*,*) &
19618 &' Illegal initialization by RLUXGO, negative input seed'
19619 if (ins .gt. 0) then
19620 jseed = ins
19621 write(*,'(A,3I12)') ' RANLUX INITIALIZED BY RLUXGO FROM SEEDS', &
19622 &jseed, k1,k2
19623 else
19624 jseed = jsdflt
19625 write(*,*)' RANLUX INITIALIZED BY RLUXGO FROM DEFAULT SEED'
19626 endif
19627 inseed = jseed
19628 notyet = .false.
19629 twom24 = 1.
19630 do 325 i= 1, 24
19631 twom24 = twom24 * 0.5
19632 k = jseed/53668
19633 jseed = 40014*(jseed-k*53668) -k*12211
19634 if (jseed .lt. 0) jseed = jseed+icons
19635 iseeds(i) = mod(jseed,itwo24)
19636 325 continue
19637 twom12 = twom24 * 4096.
19638 do 350 i= 1,24
19639 seeds(i) = real(iseeds(i))*twom24
19640 next(i) = i-1
19641 350 continue
19642 next(1) = 24
19643 i24 = 24
19644 j24 = 10
19645 carry = 0.
19646 if (seeds(24) .eq. 0.) carry = twom24
19647 ! If restarting at a break point, skip K1 + IGIGA*K2
19648 ! Note that this is the number of numbers delivered to
19649 ! the user PLUS the number skipped (if luxury .GT. 0).
19650 kount = k1
19651 mkount = k2
19652 if (k1+k2 .ne. 0) then
19653 do 500 iouter= 1, k2+1
19654 inner = igiga
19655 if (iouter .eq. k2+1) inner = k1
19656 do 450 isk= 1, inner
19657 uni = seeds(j24) - seeds(i24) - carry
19658 if (uni .lt. 0.) then
19659 uni = uni + 1.
19660 carry = twom24
19661 else
19662 carry = 0.
19663 endif
19664 seeds(i24) = uni
19665 i24 = next(i24)
19666 j24 = next(j24)
19667 450 continue
19668 500 continue
19669 ! Get the right value of IN24 by direct calculation
19670 in24 = mod(kount, nskip+24)
19671 if (mkount .gt. 0) then
19672 izip = mod(igiga, nskip+24)
19673 izip2 = mkount*izip + in24
19674 in24 = mod(izip2, nskip+24)
19675 endif
19676 ! Now IN24 had better be between zero and 23 inclusive
19677 if (in24 .gt. 23) then
19678 write(*,'(A/A,3I11,A,I5)') &
19679 &' Error in RESTARTING with RLUXGO:',' The values', ins, &
19680 &k1, k2, ' cannot occur at luxury level', luxlev
19681 in24 = 0
19682 endif
19683 endif
19684 return
19685 end
19686
19687 !cccccccccccccccccccccccccccccccccccccccccccccccccc
19688 subroutine funlxp (func,xfcum,x2low,x2high)
19689 ! F. JAMES, Sept, 1994
19690 !
19691 ! Prepares the user function FUNC for FUNLUX
19692 ! Inspired by and mostly copied from FUNPRE and FUNRAN
19693 ! except that
19694 ! 1. FUNLUX uses RANLUX underneath,
19695 ! 2. FUNLXP expands the first and last bins to cater for
19696 ! functions with long tails on left and/or right,
19697 ! 3. FUNLXP calls FUNPCT to do the actual finding of percentiles.
19698 ! 4. both FUNLXP and FUNPCT use RADAPT for Gaussian integration.
19699 !
19700 implicit none
19701 external func
19702 integer ifunc,ierr
19703 real x2high,x2low,xfcum,rteps,xhigh,xlow,xrange,uncert,x2,tftot1, &
19704 &x3,tftot2,func
19705 real tftot
19706 common/funint/tftot
19707 dimension xfcum(200)
19708 parameter (rteps=0.0002)
19709 save ifunc
19710 data ifunc/0/
19711 ifunc = ifunc + 1
19712 ! FIND RANGE WHERE FUNCTION IS NON-ZERO.
19713 call funlz(func,x2low,x2high,xlow,xhigh)
19714 xrange = xhigh-xlow
19715 if(xrange .le. 0.) then
19716 write(*,'(A,2G15.5)') ' FUNLXP finds function range .LE.0', &
19717 &xlow,xhigh
19718 go to 900
19719 endif
19720 call radapt(func,xlow,xhigh,1,rteps,0.,tftot ,uncert)
19721 ! WRITE(6,1003) IFUNC,XLOW,XHIGH,TFTOT
19722 1003 format(' FUNLXP: integral of USER FUNCTION', &
19723 &i3,' from ',e12.5,' to ',e12.5,' is ',e14.6)
19724 !
19725 ! WRITE (6,'(A,A)') ' FUNLXP preparing ',
19726 ! + 'first the whole range, then left tail, then right tail.'
19727 call funpct(func,ifunc,xlow,xhigh,xfcum,1,99,tftot,ierr)
19728 if (ierr .gt. 0) go to 900
19729 x2 = xfcum(3)
19730 call radapt(func,xlow,x2,1,rteps,0.,tftot1 ,uncert)
19731 call funpct(func,ifunc,xlow,x2 ,xfcum,101,49,tftot1,ierr)
19732 if (ierr .gt. 0) go to 900
19733 x3 = xfcum(98)
19734 call radapt(func,x3,xhigh,1,rteps,0.,tftot2 ,uncert)
19735 call funpct(func,ifunc,x3,xhigh,xfcum,151,49,tftot2,ierr)
19736 if (ierr .gt. 0) go to 900
19737 ! WRITE(6,1001) IFUNC,XLOW,XHIGH
19738 1001 format(' FUNLXP has prepared USER FUNCTION',i3, &
19739 &' between',g12.3,' and',g12.3,' for FUNLUX')
19740 return
19741 900 continue
19742 write(*,*) ' Fatal error in FUNLXP. FUNLUX will not work.'
19743 end
19744 !
19745 subroutine funpct(func,ifunc,xlow,xhigh,xfcum,nlo,nbins,tftot, &
19746 &ierr)
19747 ! Array XFCUM is filled from NLO to NLO+NBINS, which makes
19748 ! the number of values NBINS+1, or the number of bins NBINS
19749 implicit none
19750 external func
19751 integer ierr,nbins,nlo,ifunc,nz,ibin,maxz,iz,nitmax,ihome
19752 real tftot,xhigh,xlow,func,xfcum,rteps,tpctil,tz,tzmax,x,f,tcum, &
19753 &x1,f1,dxmax,fmin,fminz,xincr,tincr,xbest,dtbest,tpart,x2,precis, &
19754 &refx,uncert,tpart2,dtpar2,dtabs,aberr
19755 dimension xfcum(*)
19756 parameter (rteps=0.005, nz=10, maxz=20, nitmax=6,precis=1e-6)
19757 ! DOUBLE PRECISION TPCTIL, TZ, TCUM, XINCR, DTABS,
19758 ! & TINCR, TZMAX, XBEST, DTBEST, DTPAR2
19759 !
19760 ierr = 0
19761 if (tftot .le. 0.) go to 900
19762 tpctil = tftot/nbins
19763 tz = tpctil/nz
19764 tzmax = tz * 2.
19765 xfcum(nlo) = xlow
19766 xfcum(nlo+nbins) = xhigh
19767 x = xlow
19768 f = func(x)
19769 if (f .lt. 0.) go to 900
19770 ! Loop over percentile bins
19771 do 600 ibin = nlo, nlo+nbins-2
19772 tcum = 0.
19773 x1 = x
19774 f1 = f
19775 dxmax = (xhigh -x) / nz
19776 fmin = tz/dxmax
19777 fminz = fmin
19778 ! Loop over trapezoids within a supposed percentil
19779 do 500 iz= 1, maxz
19780 xincr = tz/max(f1,fmin,fminz)
19781 350 x = x1 + xincr
19782 f = func(x)
19783 if (f .lt. 0.) go to 900
19784 tincr = (x-x1) * 0.5 * (f+f1)
19785 if (tincr .lt. tzmax) go to 370
19786 xincr = xincr * 0.5
19787 go to 350
19788 370 continue
19789 tcum = tcum + tincr
19790 if (tcum .ge. tpctil*0.99) go to 520
19791 fminz = tz*f/ (tpctil-tcum)
19792 f1 = f
19793 x1 = x
19794 500 continue
19795 write(*,*) ' FUNLUX: WARNING. FUNPCT fails trapezoid.'
19796 ! END OF TRAPEZOID LOOP
19797 ! Adjust interval using Gaussian integration with
19798 ! Newton corrections since F is the derivative
19799 520 continue
19800 x1 = xfcum(ibin)
19801 xbest = x
19802 dtbest = tpctil
19803 tpart = tpctil
19804 ! Allow for maximum NITMAX more iterations on RADAPT
19805 do 550 ihome= 1, nitmax
19806 535 xincr = (tpctil-tpart) / max(f,fmin)
19807 x = xbest + xincr
19808 x2 = x
19809 if (ihome .gt. 1 .and. x2 .eq. xbest) then
19810 write(*,'(A,G12.3)') &
19811 &' FUNLUX: WARNING from FUNPCT: insufficient precision at X=',x
19812 go to 580
19813 endif
19814 refx = abs(x)+precis
19815 call radapt(func,x1,x2,1,rteps,0.,tpart2,uncert)
19816 dtpar2 = tpart2-tpctil
19817 dtabs = abs(dtpar2)
19818 if(abs(xincr)/refx .lt. precis) goto 545
19819 if(dtabs .lt. dtbest) goto 545
19820 xincr = xincr * 0.5
19821 goto 535
19822 545 dtbest = dtabs
19823 xbest = x
19824 tpart = tpart2
19825 f = func(x)
19826 if(f .lt. 0.) goto 900
19827 if(dtabs .lt. rteps*tpctil) goto 580
19828 550 continue
19829 write(*,'(A,I4)') &
19830 &' FUNLUX: WARNING from FUNPCT: cannot converge, bin',ibin
19831 !
19832 580 continue
19833 xincr = (tpctil-tpart) / max(f,fmin)
19834 x = xbest + xincr
19835 xfcum(ibin+1) = x
19836 f = func(x)
19837 if(f .lt. 0.) goto 900
19838 600 continue
19839 ! END OF LOOP OVER BINS
19840 x1 = xfcum(nlo+nbins-1)
19841 x2 = xhigh
19842 call radapt(func,x1,x2,1,rteps,0.,tpart ,uncert)
19843 aberr = abs(tpart-tpctil)/tftot
19844 ! WRITE(6,1001) IFUNC,XLOW,XHIGH
19845 if(aberr .gt. rteps) write(*,1002) aberr
19846 return
19847 900 write(*,1000) x,f
19848 ierr = 1
19849 return
19850 1000 format(/' FUNLUX fatal error in FUNPCT: function negative:'/ &
19851 &,' at X=',e15.6,', F=',e15.6/)
19852 ! 1001 FORMAT(' FUNPCT has prepared USER FUNCTION',I3,
19853 ! + ' between',G12.3,' and',G12.3,' for FUNLUX.')
19854 1002 format(' WARNING: Relative error in cumulative distribution', &
19855 &' may be as big as',f10.7)
19856 end
19857
19858 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
19859
19860 subroutine funlux(array,xran,len)
19861 ! Generation of LEN random numbers in any given distribution,
19862 ! by 4-point interpolation in the inverse cumulative distr.
19863 ! which was previously generated by FUNLXP
19864 implicit none
19865 real tftot
19866 common/funint/tftot
19867 integer len,ibuf,j,j1
19868 real array,xran,gap,gapinv,tleft,bright,gaps,gapins,x,p,a,b
19869 dimension array(200)
19870 dimension xran(len)
19871 ! Bin width for main sequence, and its inverse
19872 parameter (gap= 1./99., gapinv=99.)
19873 ! Top of left tail, bottom of right tail (each tail replaces 2 bins)
19874 parameter (tleft= 2./99.,bright=97./99.)
19875 ! Bin width for minor sequences (tails), and its inverse
19876 parameter (gaps=tleft/49., gapins=1./gaps)
19877 !
19878 ! The array ARRAY is assumed to have the following structure:
19879 ! ARRAY(1-100) contains the 99 bins of the inverse cumulative
19880 ! distribution of the entire function.
19881 ! ARRAY(101-150) contains the 49-bin blowup of main bins
19882 ! 1 and 2 (left tail of distribution)
19883 ! ARRAY(151-200) contains the 49-bin blowup of main bins
19884 ! 98 and 99 (right tail of distribution)
19885 !
19886 call ranlux(xran,len)
19887
19888 do 500 ibuf= 1, len
19889 x = xran(ibuf)
19890 j = int( x *gapinv) + 1
19891 if (j .lt. 3) then
19892 j1 = int( x *gapins)
19893 j = j1 + 101
19894 j = max(j,102)
19895 j = min(j,148)
19896 p = ( x -gaps*(j1-1)) * gapins
19897 a = (p+1.0) * array(j+2) - (p-2.0)*array(j-1)
19898 b = (p-1.0) * array(j) - p * array(j+1)
19899 xran(ibuf) = a*p*(p-1.0)*0.16666667 + b*(p+1.)*(p-2.)*0.5
19900 else if (j .gt. 97) then
19901 j1 = int((x-bright)*gapins)
19902 j = j1 + 151
19903 j = max(j,152)
19904 j = min(j,198)
19905 p = (x -bright -gaps*(j1-1)) * gapins
19906 a = (p+1.0) * array(j+2) - (p-2.0)*array(j-1)
19907 b = (p-1.0) * array(j) - p * array(j+1)
19908 xran(ibuf) = a*p*(p-1.0)*0.16666667 + b*(p+1.)*(p-2.)*0.5
19909 else
19910 ! J = MAX(J,2)
19911 ! J = MIN(J,98)
19912 p = ( x -gap*(j-1)) * gapinv
19913 a = (p+1.) * array(j+2) - (p-2.)*array(j-1)
19914 b = (p-1.) * array(j) - p * array(j+1)
19915 xran(ibuf) = a*p*(p-1.)*0.16666667 + b*(p+1.)*(p-2.)*0.5
19916 endif
19917 500 continue
19918 tftot = x
19919 return
19920 end
19921 subroutine funlz(func,x2low,x2high,xlow,xhigh)
19922 ! FIND RANGE WHERE FUNC IS NON-ZERO.
19923 ! WRITTEN 1980, F. JAMES
19924 ! MODIFIED, NOV. 1985, TO FIX BUG AND GENERALIZE
19925 ! TO FIND SIMPLY-CONNECTED NON-ZERO REGION (XLOW,XHIGH)
19926 ! ANYWHERE WITHIN THE GIVEN REGION (X2LOW,H2HIGH).
19927 ! WHERE 'ANYWHERE' MEANS EITHER AT THE LOWER OR UPPER
19928 ! EDGE OF THE GIVEN REGION, OR, IF IN THE MIDDLE,
19929 ! COVERING AT LEAST 1% OF THE GIVEN REGION.
19930 ! OTHERWISE IT IS NOT GUARANTEED TO FIND THE NON-ZERO REGION.
19931 ! IF FUNCTION EVERYWHERE ZERO, FUNLZ SETS XLOW=XHIGH=0.
19932 implicit none
19933 external func
19934 integer logn,nslice,i,k
19935 real xhigh,xlow,x2high,x2low,func,xmid,xh,xl,xnew
19936 xlow = x2low
19937 xhigh = x2high
19938 ! FIND OUT IF FUNCTION IS ZERO AT ONE END OR BOTH
19939 xmid = xlow
19940 if (func(xlow) .gt. 0.) go to 120
19941 xmid = xhigh
19942 if (func(xhigh) .gt. 0.) go to 50
19943 ! FUNCTION IS ZERO AT BOTH ENDS,
19944 ! LOOK FOR PLACE WHERE IT IS NON-ZERO.
19945 do 30 logn= 1, 7
19946 nslice = 2**logn
19947 do 20 i= 1, nslice, 2
19948 xmid = xlow + i * (xhigh-xlow) / nslice
19949 if (func(xmid) .gt. 0.) go to 50
19950 20 continue
19951 30 continue
19952 ! FALLING THROUGH LOOP MEANS CANNOT FIND NON-ZERO VALUE
19953 write(*,554)
19954 write(*,555) xlow, xhigh
19955 xlow = 0.
19956 xhigh = 0.
19957 go to 220
19958 !
19959 50 continue
19960 ! DELETE 'LEADING' ZERO RANGE
19961 xh = xmid
19962 xl = xlow
19963 do 70 k= 1, 20
19964 xnew = 0.5*(xh+xl)
19965 if (func(xnew) .eq. 0.) go to 68
19966 xh = xnew
19967 go to 70
19968 68 xl = xnew
19969 70 continue
19970 xlow = xl
19971 write(*,555) x2low,xlow
19972 120 continue
19973 if (func(xhigh) .gt. 0.) go to 220
19974 ! DELETE 'TRAILING' RANGE OF ZEROES
19975 xl = xmid
19976 xh = xhigh
19977 do 170 k= 1, 20
19978 xnew = 0.5*(xh+xl)
19979 if (func(xnew) .eq. 0.) go to 168
19980 xl = xnew
19981 go to 170
19982 168 xh = xnew
19983 170 continue
19984 xhigh = xh
19985 write(*,555) xhigh, x2high
19986 !
19987 220 continue
19988 return
19989 554 format('0CANNOT FIND NON-ZERO FUNCTION VALUE')
19990 555 format(' FUNCTION IS ZERO FROM X=',e12.5,' TO ',e12.5)
19991 end
19992 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
19993 !
19994 ! $Id: radapt.F,v 1.1.1.1 1996/04/01 15:02:13 mclareni Exp $
19995 !
19996 ! $Log: radapt.F,v $
19997 ! Revision 1.1.1.1 1996/04/01 15:02:13 mclareni
19998 ! Mathlib gen
19999 !
20000 !
20001 subroutine radapt(f,a,b,nseg,reltol,abstol,res,err)
20002
20003 ! RES = Estimated Integral of F from A to B,
20004 ! ERR = Estimated absolute error on RES.
20005 ! NSEG specifies how the adaptation is to be done:
20006 ! =0 means use previous binning,
20007 ! =1 means fully automatic, adapt until tolerance attained.
20008 ! =n>1 means first split interval into n equal segments,
20009 ! then adapt as necessary to attain tolerance.
20010 ! The specified tolerances are:
20011 ! relative: RELTOL ; absolute: ABSTOL.
20012 ! It stop s when one OR the other is satisfied, or number of
20013 ! segments exceeds NDIM. Either TOLA or TOLR (but not both!)
20014 ! can be set to zero, in which case only the other is used.
20015
20016 implicit none
20017 external f
20018 integer nseg,ndim,nter,nsegd,i,iter,ibig
20019 real err,res,abstol,reltol,b,a,xlo,xhi,tval,ters,te,root,xhib, &
20020 &bin,xlob,bige,hf,xnew,r1,f
20021 double precision tvals,terss
20022
20023 parameter (ndim=100)
20024 parameter (r1 = 1., hf = r1/2.)
20025
20026 dimension xlo(ndim),xhi(ndim),tval(ndim),ters(ndim)
20027 save xlo,xhi,tval,ters,nter
20028 data nter /0/
20029
20030 if(nseg .le. 0) then
20031 if(nter .eq. 0) then
20032 nsegd=1
20033 go to 2
20034 endif
20035 tvals=0d0
20036 terss=0d0
20037 do 1 i = 1,nter
20038 call rgs56p(f,xlo(i),xhi(i),tval(i),te)
20039 ters(i)=te**2
20040 tvals=tvals+tval(i)
20041 terss=terss+ters(i)
20042 1 continue
20043 root= sqrt(2.*terss)
20044 go to 9
20045 endif
20046 nsegd=min(nseg,ndim)
20047 2 xhib=a
20048 bin=(b-a)/nsegd
20049 do 3 i = 1,nsegd
20050 xlo(i)=xhib
20051 xlob=xlo(i)
20052 xhi(i)=xhib+bin
20053 if(i .eq. nsegd) xhi(i)=b
20054 xhib=xhi(i)
20055 call rgs56p(f,xlob,xhib,tval(i),te)
20056 ters(i)=te**2
20057 3 continue
20058 nter=nsegd
20059 do 4 iter = 1,ndim
20060 tvals=tval(1)
20061 terss=ters(1)
20062 do 5 i = 2,nter
20063 tvals=tvals+tval(i)
20064 terss=terss+ters(i)
20065 5 continue
20066 root= sqrt(2.*terss)
20067 if(root .le. abstol .or. root .le. reltol*abs(tvals)) go to 9
20068 if(nter .eq. ndim) go to 9
20069 bige=ters(1)
20070 ibig=1
20071 do 6 i = 2,nter
20072 if(ters(i) .gt. bige) then
20073 bige=ters(i)
20074 ibig=i
20075 endif
20076 6 continue
20077 nter=nter+1
20078 xhi(nter)=xhi(ibig)
20079 xnew=hf*(xlo(ibig)+xhi(ibig))
20080 xhi(ibig)=xnew
20081 xlo(nter)=xnew
20082 call rgs56p(f,xlo(ibig),xhi(ibig),tval(ibig),te)
20083 ters(ibig)=te**2
20084 call rgs56p(f,xlo(nter),xhi(nter),tval(nter),te)
20085 ters(nter)=te**2
20086 4 continue
20087 9 res=tvals
20088 err=root
20089 return
20090 end
20091
20092 !cccccccccccccccccccccccccccccccccccccccccccccccccccccc
20093
20094 !
20095 ! $Id: rgs56p.F,v 1.1.1.1 1996/04/01 15:02:14 mclareni Exp $
20096 !
20097 ! $Log: rgs56p.F,v $
20098 ! Revision 1.1.1.1 1996/04/01 15:02:14 mclareni
20099 ! Mathlib gen
20100 !
20101 !
20102 subroutine rgs56p(f,a,b,res,err)
20103 implicit none
20104 integer i
20105 real err,res,b,a,f,w6,x6,w5,x5,rang,r1,hf
20106 double precision e5,e6
20107
20108 parameter (r1 = 1., hf = r1/2.)
20109 dimension x5(5),w5(5),x6(6),w6(6)
20110
20111 data (x5(i),w5(i),i=1,5) &
20112 &/4.6910077030668004e-02, 1.1846344252809454e-01, &
20113 &2.3076534494715846e-01, 2.3931433524968324e-01, &
20114 &5.0000000000000000e-01, 2.8444444444444444e-01, &
20115 &7.6923465505284154e-01, 2.3931433524968324e-01, &
20116 &9.5308992296933200e-01, 1.1846344252809454e-01/
20117
20118 data (x6(i),w6(i),i=1,6) &
20119 &/3.3765242898423989e-02, 8.5662246189585178e-02, &
20120 &1.6939530676686775e-01, 1.8038078652406930e-01, &
20121 &3.8069040695840155e-01, 2.3395696728634552e-01, &
20122 &6.1930959304159845e-01, 2.3395696728634552e-01, &
20123 &8.3060469323313225e-01, 1.8038078652406930e-01, &
20124 &9.6623475710157601e-01, 8.5662246189585178e-02/
20125
20126 rang=b-a
20127 e5=0d0
20128 e6=0d0
20129 do 1 i = 1,5
20130 e5=e5+w5(i)*f(a+rang*x5(i))
20131 e6=e6+w6(i)*f(a+rang*x6(i))
20132 1 continue
20133 e6=e6+w6(6)*f(a+rang*x6(6))
20134 res=hf*(e6+e5)*rang
20135 err=abs((e6-e5)*rang)
20136 return
20137 end
20138 !GRD
20139 !
20140 !*********************************************************************
20141 !
20142 ! Define INTEGER function MCLOCK that can differ from system to system
20143 !
20144 !*********************************************************************
20145 !
20146 integer function mclock_liar( )
20147 !
20148 implicit none
20149 save
20150 !
20151 integer mclock
20152 integer count_rate, count_max
20153 logical clock_ok
20154 !
20155 ! MCLOCK_LIAR = MCLOCK()
20156 !
20157 clock_ok = .true.
20158 !
20159 if (clock_ok) then
20160 !
20161 call system_clock( mclock, count_rate, count_max )
20162 if ( count_max .eq. 0 ) then
20163 clock_ok = .false.
20164 write(*,*)'INFO> System Clock not present or not', &
20165 &' Responding'
20166 write(*,*)'INFO> R.N.G. Reseed operation disabled.'
20167 endif
20168 !
20169 endif
20170 !
20171 mclock_liar = mclock
20172 !
20173 return
20174 end
20175 double precision function ran_gauss(cut)
20176 !*********************************************************************
20177 !
20178 ! RAN_GAUSS - will generate a normal distribution from a uniform
20179 ! distribution between [0,1].
20180 ! See "Communications of the ACM", V. 15 (1972), p. 873.
20181 !
20182 ! cut - double precision - cut for distribution in units of sigma
20183 ! the cut must be greater than 0.5
20184 !
20185 !*********************************************************************
20186 implicit none
20187
20188 logical flag
20189 real rndm4
20190 double precision x, u1, u2, twopi, r,cut
20191 save
20192
20193 twopi=8d0*atan(1d0)
20194 1 if (flag) then
20195 r = dble(rndm4( ))
20196 r = max(r, 0.5d0**32)
20197 r = min(r, 1d0-0.5d0**32)
20198 u1 = sqrt(-2d0*log( r ))
20199 u2 = dble(rndm4( ))
20200 x = u1 * cos(twopi*u2)
20201 else
20202 x = u1 * sin(twopi*u2)
20203 endif
20204
20205 flag = .not. flag
20206
20207 ! cut the distribution if cut > 0.5
20208 if (cut .gt. 0.5d0 .and. abs(x) .gt. cut) goto 1
20209
20210 ran_gauss = x
20211 return
20212 end
20213 subroutine readcollimator
20214 !
20215 integer I,J,K
20216 integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1, &
20217 &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran, &
20218 &nrco,ntr,nzfz
20219 parameter(npart = 64,nmac = 1)
20220 parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000, &
20221 &nzfz = 300000,mmul = 11)
20222 parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5, &
20223 &nema = 15)
20224 parameter(mcor = 10,mcop = mcor+6, mbea = 15)
20225 parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
20226 parameter(nmon1 = 600,ncor1 = 600)
20227 parameter(ntr = 20,nbb = 160)
20228 integer max_ncoll,max_npart,maxn,numeff,outlun,nc
20229 !UPGRADE January 2005
20230 ! PARAMETER (MAX_NCOLL=68,MAX_NPART=20000,nc=32,NUMEFF=19,
20231 parameter (max_ncoll=100,max_npart=20000,nc=32,numeff=19, &
20232 &maxn=20000,outlun=54)
20233 !GRD
20234 !GRD THIS BLOC IS COMMON TO MAINCR, DATEN, TRAUTHIN AND THIN6D
20235 !GRD
20236 !APRIL2005
20237 logical do_coll,do_select,do_nominal,dowrite_dist,do_oneside, &
20238 &dowrite_impact,dowrite_secondary,dowrite_amplitude,radial, &
20239 &systilt_antisymm,dowritetracks,cern,do_nsig,do_mingap
20240 ! &systilt_antisymm,dowritetracks,cern
20241 !APRIL2005
20242 !
20243 ! integer nloop,rnd_seed,ibeam,jobnumber,sigsecut2
20244 !JUNE2005
20245 ! integer nloop,rnd_seed,ibeam,jobnumber
20246 !SEPT2005 for slicing process
20247 ! integer nloop,rnd_seed,ibeam,jobnumber,do_thisdis
20248 integer nloop,rnd_seed,c_offsettilt_seed,ibeam,jobnumber, &
20249 &do_thisdis,n_slices,pencil_distr
20250 !JUNE2005
20251 !
20252 !UPGRADE JANUARY 2005
20253 !APRIL2005
20254 ! double precision myenom,mynex,mdex,myney,mdey,nsig_prim,nsig_sec, &
20255 ! &nsig_ter,emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase, &
20256 double precision myenom,mynex,mdex,myney,mdey, &
20257 &nsig_tcp3,nsig_tcsg3,nsig_tcsm3,nsig_tcla3, &
20258 &nsig_tcp7,nsig_tcsg7,nsig_tcsm7,nsig_tcla7,nsig_tclp,nsig_tcli, &
20259 !
20260 &nsig_tcth1,nsig_tcth2,nsig_tcth5,nsig_tcth8, &
20261 &nsig_tctv1,nsig_tctv2,nsig_tctv5,nsig_tctv8, &
20262 !
20263 &nsig_tcdq,nsig_tcstcdq,nsig_tdi,nsig_tcxrp,nsig_tcryo, nsig_cry, &
20264 !SEPT2005 add these lines for the slicing procedure
20265 &smin_slices,smax_slices,recenter1,recenter2, &
20266 &fit1_1,fit1_2,fit1_3,fit1_4,fit1_5,fit1_6,ssf1, &
20267 &fit2_1,fit2_2,fit2_3,fit2_4,fit2_5,fit2_6,ssf2, &
20268 !SEPT2005,OCT2006 added offset
20269 &emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase, &
20270 &c_rmstilt_prim,c_rmstilt_sec,c_systilt_prim,c_systilt_sec, &
20271 &c_rmsoffset_prim,c_rmsoffset_sec,c_sysoffset_prim, &
20272 &c_sysoffset_sec,c_rmserror_gap,nr,ndr, &
20273 ! &driftsx,driftsy,pencil_offset,sigsecut3
20274 !JUNE2005
20275 ! &driftsx,driftsy,pencil_offset,sigsecut3,sigsecut2
20276 &driftsx,driftsy,pencil_offset,pencil_rmsx,pencil_rmsy, &
20277 &sigsecut3,sigsecut2,enerror,bunchlength
20278 !JUNE2005
20279 !APRIL2005
20280 !
20281 character*24 name_sel
20282 character*80 coll_db
20283 character*16 castordir
20284 !JUNE2005
20285 character*80 filename_dis
20286 !JUNE2005
20287 !
20288 !UPGRADE JANUARY 2005
20289 !APRIL2005
20290 !JUNE2005
20291 !SEPT2005
20292 ! common /grd/ myenom,mynex,mdex,myney,mdey,nsig_prim,nsig_sec, &
20293 ! &nsig_ter,emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase, &
20294 ! &c_rmstilt_prim,c_rmstilt_sec,c_systilt_prim,c_systilt_sec,nr, &
20295 ! &ndr,driftsx,driftsy,pencil_offset,sigsecut3,coll_db,name_sel, &
20296 ! &castordir,abs_db,nloop,rnd_seed,ibeam,jobnumber,sigsecut2,do_coll,&
20297 ! &do_select,do_nominal,dowrite_dist,do_oneside,dowrite_impact, &
20298 ! &dowrite_secondary,dowrite_amplitude,radial,systilt_antisymm, &
20299 ! &dowritetracks,cern
20300 common /grd/ myenom,mynex,mdex,myney,mdey, &
20301 &nsig_tcp3,nsig_tcsg3,nsig_tcsm3,nsig_tcla3, &
20302 &nsig_tcp7,nsig_tcsg7,nsig_tcsm7,nsig_tcla7,nsig_tclp,nsig_tcli, &
20303 !
20304 &nsig_tcth1,nsig_tcth2,nsig_tcth5,nsig_tcth8, &
20305 &nsig_tctv1,nsig_tctv2,nsig_tctv5,nsig_tctv8, &
20306 !
20307 &nsig_tcdq,nsig_tcstcdq,nsig_tdi,nsig_tcxrp,nsig_tcryo, nsig_cry, &
20308 !
20309 &smin_slices,smax_slices,recenter1,recenter2, &
20310 &fit1_1,fit1_2,fit1_3,fit1_4,fit1_5,fit1_6,ssf1, &
20311 &fit2_1,fit2_2,fit2_3,fit2_4,fit2_5,fit2_6,ssf2, &
20312 !
20313 &emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase, &
20314 &c_rmstilt_prim,c_rmstilt_sec,c_systilt_prim,c_systilt_sec, &
20315 &c_rmsoffset_prim,c_rmsoffset_sec,c_sysoffset_prim, &
20316 &c_sysoffset_sec,c_rmserror_gap,nr, &
20317 !
20318 &ndr,driftsx,driftsy,pencil_offset,pencil_rmsx,pencil_rmsy, &
20319 &sigsecut3,sigsecut2,enerror, &
20320 &bunchlength,coll_db,name_sel, &
20321 &castordir,filename_dis,nloop,rnd_seed,c_offsettilt_seed, &
20322 &ibeam,jobnumber,do_thisdis,n_slices,pencil_distr, &
20323 &do_coll, &
20324 !
20325 &do_select,do_nominal,dowrite_dist,do_oneside,dowrite_impact, &
20326 &dowrite_secondary,dowrite_amplitude,radial,systilt_antisymm, &
20327 &dowritetracks,cern,do_nsig,do_mingap
20328 !SEPT2005
20329 !JUNE2005
20330 !APRIL2005
20331 !
20332 !--September 2006 -- TW common to readcollimator and collimate2
20333 ! logical changed_tilt1(max_ncoll)
20334 ! logical changed_tilt2(max_ncoll)
20335 ! common /tilt/ changed_tilt1, changed_tilt2
20336 !--September 2006
20337 !
20338 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
20339 !
20340 !
20341 ! THIS BLOCK IS COMMON TO BOTH THIN6D AND TRAUTHIN SUBROUTINES
20342 !
20343 integer ieff
20344 double precision myemitx0,myemity0,myalphay,mybetay,myalphax, &
20345 &mybetax,rselect
20346 common /ralph/ myemitx0,myemity0,myalphax,myalphay,mybetax, &
20347 &mybetay,rselect
20348 !
20349 integer absorbed(npart),counted(npart,numeff)
20350 double precision neff(numeff),rsig(numeff)
20351 common /eff/ neff,rsig,counted,absorbed
20352 !
20353 integer nimpact(50)
20354 double precision sumimpact(50),sqsumimpact(50)
20355 common /rimpact/ sumimpact,sqsumimpact,nimpact
20356 !
20357 integer nampl(nblz)
20358 character*16 ename(nblz)
20359 double precision sum_ax(nblz),sqsum_ax(nblz),sum_ay(nblz), &
20360 &sqsum_ay(nblz),sampl(nblz)
20361 common /ampl_rev/ sum_ax,sqsum_ax,sum_ay,sqsum_ay,sampl,ename, &
20362 &nampl
20363 !
20364 double precision neffx(numeff),neffy(numeff)
20365 common /efficiency/ neffx,neffy
20366 !
20367 integer part_hit(maxn),part_abs(maxn),n_tot_absorbed,n_absorbed &
20368 &,part_select(maxn)
20369 double precision part_impact(maxn)
20370 common /stats/ part_impact,part_hit,part_abs
20371 common /n_tot_absorbed/ n_tot_absorbed,n_absorbed
20372 common /part_select/ part_select
20373 !
20374 double precision x00(maxn),xp00(maxn),y00(maxn),yp00(maxn)
20375 common /beam00/ x00,xp00,y00,yp00
20376 !
20377 logical firstrun
20378 common /firstrun/ firstrun
20379 !
20380 integer nsurvive,nsurvive_end,num_selhit,n_impact
20381 common /outcoll/ nsurvive,num_selhit,n_impact,nsurvive_end
20382 !
20383 integer napx00
20384 common /napx00/ napx00
20385 !
20386 integer icoll
20387 common /icoll/ icoll
20388 !
20389 !UPGRADE January 2005
20390 ! INTEGER DB_NCOLL
20391 integer db_ncoll
20392 !
20393 character*16 db_name1(max_ncoll),db_name2(max_ncoll)
20394 character*6 db_material(max_ncoll)
20395 !APRIL2005
20396 double precision db_nsig(max_ncoll),db_length(max_ncoll), &
20397 &db_offset(max_ncoll),db_rotation(max_ncoll), &
20398 &db_bx(max_ncoll),db_by(max_ncoll),db_tilt(max_ncoll,2), &
20399 &db_elense_thickness(max_ncoll),db_elense_j_e(max_ncoll) &
20400 &,db_cry_rcurv(max_ncoll),db_cry_rmax(max_ncoll), &
20401 &db_cry_zmax(max_ncoll),db_cry_alayer(max_ncoll), &
20402 &db_cry_orient(max_ncoll),db_cry_tilt(max_ncoll)
20403 &,db_miscut(max_ncoll)
20404 common /colldatabase/ db_nsig,db_length,db_rotation,db_offset, &
20405 &db_bx,db_by,db_tilt,db_name1,db_name2,db_material,db_ncoll, &
20406 &db_elense_thickness,db_elense_j_e &
20407 &,db_cry_rcurv,db_cry_rmax,db_cry_zmax,db_cry_alayer,db_cry_orient,&
20408 &db_cry_tilt,db_miscut
20409
20410 ! double precision db_length(max_ncoll),db_rotation(max_ncoll), &
20411 ! &db_offset(max_ncoll), &
20412 ! &db_bx(max_ncoll),db_by(max_ncoll),db_tilt(max_ncoll,2)
20413 ! common /colldatabase/ db_length,db_rotation,db_offset,db_bx,db_by,&
20414 !! &DB_TILT,DB_NAME1,DB_NAME2,DB_MATERIAL,DB_NCOLL
20415 ! &db_tilt,db_name1,db_name2,db_material,db_ncoll,db_nabs,db_ntot, &
20416 ! &db_startabs
20417 !APRIL2005
20418 !
20419 integer cn_impact(max_ncoll),cn_absorbed(max_ncoll)
20420 double precision caverage(max_ncoll),csigma(max_ncoll)
20421 common /collsummary/ caverage,csigma,cn_impact,cn_absorbed
20422 !
20423 double precision myx(maxn),myxp(maxn),myy(maxn),myyp(maxn), &
20424 &myp(maxn),mys(maxn)
20425 common /coord/ myx,myxp,myy,myyp,myp,mys
20426 !
20427 integer counted_r(maxn,numeff),counted_x(maxn,numeff), &
20428 &counted_y(maxn,numeff), &
20429 &ieffmax_r(npart),ieffmax_x(npart),ieffmax_y(npart)
20430 common /counting/ counted_r,counted_x,counted_y,ieffmax_r, &
20431 &ieffmax_x, ieffmax_y
20432 !
20433 !APRIL2005
20434 ! integer secondary(maxn),tertiary(maxn),part_hit_before(maxn)
20435 integer secondary(maxn),tertiary(maxn),other(maxn), &
20436 &part_hit_before(maxn)
20437 !APRIL2005
20438 double precision part_indiv(maxn),part_linteract(maxn)
20439 !
20440 integer samplenumber
20441 character*4 smpl
20442 character*80 pfile
20443 common /samplenumber/ pfile,smpl,samplenumber
20444 !
20445 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
20446 !
20447 !
20448 save
20449 !
20450 !--------------------------------------------------------------------
20451 !++ Read collimator database
20452 !
20453 ! write(*,*) 'reading collimator database'
20454 open(unit=53,file=coll_db)
20455 !
20456 ! write(*,*) 'inside collimator database'
20457 I = 0
20458 read(53,*)
20459 read(53,*,iostat=ios) db_ncoll
20460 ! write(*,*) 'ios = ',ios
20461 if (ios.ne.0) then
20462 write(outlun,*) 'ERR> Problem reading collimator DB ',ios
20463 stop
20464 endif
20465 if (db_ncoll.gt.max_ncoll) then
20466 write(*,*) 'ERR> db_ncoll > max_ncoll '
20467 stop
20468 endif
20469 !
20470 do j=1,db_ncoll
20471 ! write(*,*) 'inside collimator database',j
20472 read(53,*)
20473 !GRD
20474 !GRD ALLOW TO RECOGNIZE BOTH CAPITAL AND NORMAL LETTERS
20475 !GRD
20476 read(53,*,iostat=ios) db_name1(j)
20477 ! write(*,*) 'ios = ',ios
20478 if (ios.ne.0) then
20479 write(outlun,*) 'ERR> Problem reading collimator DB ', j,ios
20480 stop
20481 endif
20482 !
20483 read(53,*,iostat=ios) db_name2(j)
20484 ! write(*,*) 'ios = ',ios
20485 if (ios.ne.0) then
20486 write(outlun,*) 'ERR> Problem reading collimator DB ', j,ios
20487 stop
20488 endif
20489 !
20490 read(53,*,iostat=ios) db_nsig(j)
20491 ! write(*,*) 'ios = ',ios
20492 if (ios.ne.0) then
20493 write(outlun,*) 'ERR> Problem reading collimator DB ', j,ios
20494 stop
20495 endif
20496 !GRD
20497 read(53,*,iostat=ios) db_material(j)
20498 ! write(*,*) 'ios = ',ios
20499 if (ios.ne.0) then
20500 write(outlun,*) 'ERR> Problem reading collimator DB ', j,ios
20501 stop
20502 endif
20503 read(53,*,iostat=ios) db_length(j)
20504 ! write(*,*) 'ios = ',ios
20505 if (ios.ne.0) then
20506 write(outlun,*) 'ERR> Problem reading collimator DB ', j,ios
20507 stop
20508 endif
20509 read(53,*,iostat=ios) db_rotation(j)
20510 ! write(*,*) 'ios = ',ios
20511 if (ios.ne.0) then
20512 write(outlun,*) 'ERR> Problem reading collimator DB ', j,ios
20513 stop
20514 endif
20515 read(53,*,iostat=ios) db_offset(j)
20516 ! write(*,*) 'ios = ',ios
20517 if (ios.ne.0) then
20518 write(outlun,*) 'ERR> Problem reading collimator DB ', j,ios
20519 stop
20520 endif
20521 c-~-o-~-o-~-o-~-o-~-o-~-o-~-o-~-o-~-o-Valentina-o-~-o-~-o-~-o-~-o-~-o-~-o-~-o-~-o-~-o-
20522 c
20523 c for crystal I need more parameters to be put in the database
20524 c
20525 if (db_name1(j)(1:3).EQ.'CRY') then
20526 READ(53,*,IOSTAT=ios) db_cry_rcurv(j)
20527 if (ios.NE.0) then
20528 WRITE(outlun,*) 'ERR> Problem reading collimator DB ', j, 1
20529 1 ios
20530 stop
20531 endif
20532 write(*,*) 'db_cry_rcurv(j)', db_cry_rcurv(j)
20533 READ(53,*,IOSTAT=ios) db_cry_rmax(j)
20534 if (ios.NE.0) then
20535 WRITE(outlun,*) 'ERR> Problem reading collimator DB ', j, 1
20536 1 ios
20537 STOP
20538 endif
20539 write(*,*) 'db_cry_rmax(j)', db_cry_rmax(j)
20540 READ(53,*,IOSTAT=ios) db_cry_zmax(j)
20541 if (ios.NE.0) then
20542 WRITE(outlun,*) 'ERR> Problem reading collimator DB ', j, 1
20543 1 ios
20544 STOP
20545 endif
20546 write(*,*) 'db_cry_zmax(j)', db_cry_zmax(j)
20547 READ(53,*,IOSTAT=ios) db_cry_alayer(j)
20548 if (ios.NE.0) then
20549 WRITE(outlun,*) 'ERR> Problem reading collimator DB ', j, 1
20550 1 ios
20551 STOP
20552 endif
20553 write(*,*) 'db_cry_alayer(j)', db_cry_alayer(j)
20554 READ(53,*,IOSTAT=ios) db_cry_orient(j)
20555 if (ios.NE.0) then
20556 WRITE(outlun,*) 'ERR> Problem reading collimator DB ', j, 1
20557 1 ios
20558 STOP
20559 endif
20560 write(*,*) 'db_cry_orient(j)',db_cry_orient(j)
20561 READ(53,*,IOSTAT=ios) db_cry_tilt(j)
20562 if (ios.NE.0) then
20563 WRITE(outlun,*) 'ERR> Problem reading collimator DB ', j , 1
20564 1 ios
20565 STOP
20566 endif
20567 write(*,*) 'db_cry_tilt(j)', db_cry_tilt(j)
20568 READ(53,*,IOSTAT=ios) db_miscut(j)
20569 if (ios.NE.0) then
20570 WRITE(outlun,*) 'ERR> Problem reading collimator DB ', j , 1
20571 1 ios
20572 STOP
20573 endif
20574 write(*,*) 'db_miscut(j)', db_miscut(j)
20575 endif
20576 c
20577 c-~-o-~-o-~-o-~-o-~-o-~-o-~-o-~-o-~-o-Valentina-o-~-o-~-o-~-o-~-o-~-o-~-o-~-o-~-o-~-o-
20578 read(53,*,iostat=ios) db_bx(j)
20579 ! write(*,*) 'ios = ',ios
20580 if (ios.ne.0) then
20581 write(outlun,*) 'ERR> Problem reading collimator DB ', j,ios
20582 stop
20583 endif
20584 read(53,*,iostat=ios) db_by(j)
20585 ! write(*,*) 'ios = ',ios
20586 if (ios.ne.0) then
20587 write(outlun,*) 'ERR> Problem reading collimator DB ', j,ios
20588 stop
20589 endif
20590 !SEPT2008 JCSMITH
20591 ! Add special lines for electron lense
20592 if (db_name1(j)(1:5).eq.'ELENS') then &
20593 read(53,*,iostat=ios) db_elense_thickness(j), db_elense_j_e(j)
20594 if (ios.ne.0) then
20595 write(outlun,*) &
20596 & 'ERR> Problem reading collimator elense DB ',j,ios
20597 stop
20598 endif
20599 endif
20600 enddo
20601 !
20602 close(53)
20603 !
20604 end